DGPFHLR ;ALB/RPM - PRF HL7 RECEIVE DRIVERS ; 8/14/06 12:01pm
;;5.3;Registration;**425,650,951,1005**;Aug 13, 1993;Build 57
;;Per VA Directive 6402, this routine should not be modified.
;
RCV ;Receive all message types and route to message specific receiver
;
;This procedure is the main driver entry point for receiving all
;message types (ORU, ACK, QRY and ORF) for patient record flag
;assignment sharing.
;
;All procedures and functions assume that all VistA HL7 environment
;variables are properly initialized and will produce a fatal error if
;they are missing.
;
;The received message is copied to a temporary work global for
;processing. The message type is determined from the MSH segment and
;a receive processing procedure specific to the message type is called.
;(Ex. ORU~R01 message calls procedure: RCVORU). The specific receive
;processing procedure calls a message specific parse procedure to
;validate the message data and return data arrays for storage. If no
;parse errors are reported during validation, then the data arrays are
;stored by the receive processing procedure. Control, along with any
;parse validation errors, is then passed to the message specific send
;processing procedures to build and transmit the acknowledgment and
;query results messages.
;
; The message specific procedures are as follows:
;
; Message Receive Procedure Parse Procedure Send Procedure
; ------- ----------------- ---------------- --------------
; ORU~R01 RCVORU^DGPFHLR PARSORU^DGPFHLU SNDACK^DGPFHLS
; ACK~R01 RCVACK^DGPFHLR PARSACK^DGPFHLU4 N/A
; QRY~R02 RCVQRY^DGPFHLR PARSQRY^DGPFHLQ3 SNDORF^DGPFHLS
; ORF~R04 RCVORF^DGPFHLR PARSORF^DGPFHLQ3 N/A
;
N DGCNT
N DGMSGTYP
N DGSEG
N DGSEGCNT
N DGWRK
;
S DGWRK=$NA(^TMP("DGPFHL7",$J))
K @DGWRK
;
;load work global with segments
F DGSEGCNT=1:1 X HLNEXT Q:HLQUIT'>0 D
. S DGCNT=0
. S @DGWRK@(DGSEGCNT,DGCNT)=HLNODE
. F S DGCNT=$O(HLNODE(DGCNT)) Q:'DGCNT D
. . S @DGWRK@(DGSEGCNT,DGCNT)=HLNODE(DGCNT)
;
;get message type from "MSH"
I $$NXTSEG^DGPFHLUT(DGWRK,0,HL("FS"),.DGSEG),$G(DGSEG("TYPE"))="MSH" D
. S DGMSGTYP=$P(DGSEG(9),$E(HL("ECH"),1),1)
. ;HLMTIENS is only required by RCVORU and RCVQRY, thus $GET
. I DGMSGTYP=HL("MTN") D @("RCV"_DGMSGTYP_"(DGWRK,$G(HLMTIENS),.HL)")
;
;cleanup
K @DGWRK
Q
;
RCVORU(DGWRK,DGMIEN,DGHL) ;Receive ORU Message Types (ORU~R01)
;
; Input:
; DGWRK - name of work global containing segments
; DGMIEN - IEN of message entry in file #773
; DGHL - HL environment array
;
; Output:
; none
;
N DGORU
N DGSEGERR ;segment error array
N DGSTOERR ;store error array
N DGACKTYP
;
S DGORU=$NA(^TMP("DGPF",$J))
K @DGORU
D PARSORU^DGPFHLU(DGWRK,.DGHL,DGORU,.DGSEGERR)
I $D(DGSEGERR) D SDORUERR(DGMIEN,.DGSEGERR,.DGSTOERR,"P") ;parse error
;
I '$D(DGSEGERR),$$STOORU(DGORU,.DGSTOERR) D
. S DGACKTYP="AA"
E D
. S DGACKTYP="AE"
;
I $D(DGSTOERR) D SDORUERR(DGMIEN,.DGSEGERR,.DGSTOERR,"S") ;store error
D SNDACK^DGPFHLS(DGACKTYP,DGMIEN,.DGHL,.DGSEGERR,.DGSTOERR)
;
;cleanup
K @DGORU
Q
;
STOORU(DGORU,DGERR) ;store ORU data array
;
; Input:
; DGORU - parsed ORU segment data array
;
; Output:
; Function value - 1 on success; 0 on failure
; DGERR - defined on failure
;
N DGADT ;assignment date
N DGCNT ;count of assignment histories sent
N DGPFA ;assignment data array
N DGPFAH ;assignment history data array
N DGSINGLE ;flag to indicate a single history update
N CURASGN,DBRSCNT,DBRSNUM,LASTDT,RES,STOFLG
;
;
S DGPFA("SNDFAC")=$G(@DGORU@("SNDFAC"))
S DGPFA("DFN")=$G(@DGORU@("DFN"))
S DGPFA("FLAG")=$G(@DGORU@("FLAG"))
;
;init STATUS as a placeholder, $$STATUS^DGPFUT sets value in loop
S DGPFA("STATUS")=""
S DGPFA("OWNER")=$G(@DGORU@("OWNER"))
S DGPFA("ORIGSITE")=$G(@DGORU@("ORIGSITE"))
M DGPFA("NARR")=@DGORU@("NARR")
; DBRS data
S DBRSCNT=0,DBRSNUM="" F S DBRSNUM=$O(@DGORU@("DBRS",DBRSNUM)) Q:DBRSNUM="" D
.S DBRSCNT=DBRSCNT+1
.S DGPFA("DBRS#",DBRSCNT)=DBRSNUM
.S DGPFA("DBRS OTHER",DBRSCNT)=$G(@DGORU@("DBRS",DBRSNUM,"OTHER"))
.S DGPFA("DBRS DATE",DBRSCNT)=$G(@DGORU@("DBRS",DBRSNUM,"DATE"))
.S DGPFA("DBRS ACTION",DBRSCNT)=$G(@DGORU@("DBRS",DBRSNUM,"ACTION"))
.S DGPFA("DBRS SITE",DBRSCNT)=$G(@DGORU@("DBRS",DBRSNUM,"SITE"))
.Q
;count number of assignment histories sent
S (DGADT,DGCNT)=0
F S DGADT=$O(@DGORU@(DGADT)) Q:'DGADT S DGCNT=DGCNT+1
S DGSINGLE=$S(DGCNT>1:0,1:1)
S DGADT=0
S LASTDT=+$O(@DGORU@(9999999.999999),-1) ; date of last history record
;
;process only the last history action when assignment already exists
S CURASGN=$$FNDASGN^DGPFAA(DGPFA("DFN"),DGPFA("FLAG"))
I 'DGSINGLE,CURASGN S DGADT=LASTDT,DGSINGLE=1
;
F S DGADT=$O(@DGORU@(DGADT)) Q:'DGADT D Q:$D(DGERR)
.N DGPFAH ;assignment history data array
.;
.S DGPFAH("ASSIGNDT")=DGADT
.S DGPFAH("ACTION")=$G(@DGORU@(DGADT,"ACTION"))
.S DGPFAH("ENTERBY")=.5 ;POSTMASTER
.S DGPFAH("APPRVBY")=.5 ;POSTMASTER
.M DGPFAH("COMMENT")=@DGORU@(DGADT,"COMMENT")
.S DGPFAH("ORIGFAC")=$G(@DGORU@(DGADT,"ORIGFAC"))
.; DBRS data
.S DBRSCNT=0,DBRSNUM="" F S DBRSNUM=$O(@DGORU@("DBRS",DBRSNUM)) Q:DBRSNUM="" D
..S DBRSCNT=DBRSCNT+1
..S DGPFAH("DBRS",DBRSCNT)=DBRSNUM_U_$G(@DGORU@("DBRS",DBRSNUM,"OTHER"))_U_$G(@DGORU@("DBRS",DBRSNUM,"DATE"))
..I $G(@DGORU@("DBRS",DBRSNUM,"ACTION"))="U" D
...S RES=$$FIND1^DIC(26.131,","_CURASGN_",","X",DBRSNUM)
...S DGPFAH("DBRS",DBRSCNT)=DGPFAH("DBRS",DBRSCNT)_U_$S(RES:"E",1:"A")
...Q
..I $G(@DGORU@("DBRS",DBRSNUM,"ACTION"))="D" S DGPFAH("DBRS",DBRSCNT)=DGPFAH("DBRS",DBRSCNT)_U_"D"
..S DGPFAH("DBRS",DBRSCNT)=DGPFAH("DBRS",DBRSCNT)_U_$G(@DGORU@("DBRS",DBRSNUM,"SITE"))
..Q
.; calculate the assignment STATUS from the ACTION
.S DGPFA("STATUS")=$$STATUS^DGPFUT(DGPFAH("ACTION"))
.; calculate new review date if this is ownership transfer
.; if action = "continue" and current owner on file is different from owner in HL7 message, then it's an ownership transfer
.I DGPFAH("ACTION")=2,$$GET1^DIQ(26.13,CURASGN_",",.04,"I")'=DGPFA("OWNER") D
..; if local site or division is the new owner, set review date
..I DGPFA("OWNER")=$P($$SITE^VASITE(),U)!$$ISDIV^DGPFUT(DGPFA("OWNER")) D
...S DGPFA("REVIEWDT")=$$GETRDT^DGPFAA3($P(DGPFA("FLAG"),U),DGPFAH("ASSIGNDT"))
...Q
..Q
.; find out if we want to overwrite existing DBRS data
.S STOFLG="" I DGADT=LASTDT,"^2^4^5^7^8^"[(U_DGPFAH("ACTION")_U) S STOFLG="D"
.;validate before filing for single updates and new assignments
.I DGSINGLE!(DGPFAH("ACTION")=1) S RES=$$STOHL7^DGPFAA3(.DGPFA,.DGPFAH,"DGERR",STOFLG) Q
.;otherwise, just file it
.S RES=$$STOALL^DGPFAA(.DGPFA,.DGPFAH,.DGERR,STOFLG)
.Q
;convert dialog to dialog code
I $D(DGERR) S DGERR=$G(DGERR("DIERR",1))
;
Q '$D(DGERR)
;
RCVACK(DGWRK,DGMIEN,DGHL) ;Receive ACK Message Types (ACK~R01)
;
; Input:
; DGWRK - name of work global containing segments
; DGMIEN - IEN of message entry in file #773
; DGHL - HL environment array
;
; Output:
; none
;
N DGACK ;ACK data array
N DGERR ;error array
N DGLIEN ;HL7 transmission log IEN
;
D PARSACK^DGPFHLU4(DGWRK,.DGHL,.DGACK,.DGERR)
S DGLIEN=$$FNDLOG^DGPFHLL(26.17,$G(DGACK("MSGID")))
Q:'DGLIEN
;
I $G(DGACK("ACKCODE"))="AA" D
. D STOSTAT^DGPFHLL(26.17,DGLIEN,"A",.DGERR)
E D
. ;update transmission log status (REJECTED) and process error
. D STOSTAT^DGPFHLL(26.17,DGLIEN,"RJ",.DGERR)
. D PROCERR^DGPFHLU5(DGLIEN,.DGACK,.DGERR)
Q
;
RCVQRY(DGWRK,DGMIEN,DGHL) ;Receive QRY Message Types (QRY~R02)
;
; Input:
; DGWRK - name of work global containing segments
; DGMIEN - IEN of message entry in file #773
; DGHL - HL environment array
;
; Output:
; none
;
N DGDFN
N DGDFNERR
N DGQRY
N DGQRYERR
N DGSEGERR
;
D PARSQRY^DGPFHLQ3(DGWRK,.DGHL,.DGQRY,.DGSEGERR)
S DGDFN=$$GETDFN^DGPFUT2(DGQRY("ICN"),"DGDFNERR")
I DGDFN'>0,$G(DGDFNERR("DIERR",1))]"" D
. S DGQRYERR=DGDFNERR("DIERR",1)
D SNDORF^DGPFHLS(.DGQRY,DGMIEN,.DGHL,DGDFN,.DGSEGERR,.DGQRYERR)
Q
;
RCVORF(DGWRK,DGMIEN,DGHL) ;Receive ORF Message Types (ORF~R04)
;
; Input:
; DGWRK - name of work global containing segments
; DGMIEN - IEN of message entry in file #773
; DGHL - HL environment array
;
; Output:
; none
;
N DGDFN ;pointer to PATIENT (#2) file
N DGLIEN ;HL7 query log IEN
N DGORF ;ORF data array root
N DGERR ;parser error array
N DGSTAT ;query log status
;
S DGORF=$NA(^TMP("DGPF",$J))
K @DGORF
D PARSORF^DGPFHLQ4(DGWRK,.DGHL,DGORF,.DGERR)
S DGDFN=+$$GETDFN^MPIF001($G(@DGORF@("ICN")))
;
;successful query
I $G(@DGORF@("ACKCODE"))="AA" D
. S DGSTAT=$S(+$O(@DGORF@(0))>0:"A",1:"AN")
. ;
. ;REJECT when filer fails; otherwise mark event as COMPLETE
. I '$$STOORF(DGDFN,DGORF) D
. . S DGSTAT="RJ"
. . S DGERR($O(DGERR(""),-1)+1)=261120 ;Unable to file
. E D STOEVNT^DGPFHLL1(DGDFN,"C")
;
;failed query
I $G(@DGORF@("ACKCODE"))'="AA" S DGSTAT="RJ"
;
;find and update query log status
S DGLIEN=$$FNDLOG^DGPFHLL(26.19,$G(@DGORF@("MSGID")))
I DGLIEN D STOSTAT^DGPFHLL(26.19,DGLIEN,DGSTAT,.DGERR)
;
;purge PRF HL7 QUERY LOG when status is COMPLETE
I $$GETSTAT^DGPFHLL1(DGDFN)="C" D PRGQLOG^DGPFHLL($$FNDEVNT^DGPFHLL1(DGDFN))
;
;cleanup
K @DGORF
Q
;
STOORF(DGDFN,DGORF,DGERR) ;store ORF data
;
; Input:
; DGDFN - pointer to patient in PATIENT (#2) file
; DGORF - parsed ORF segments data array
;
; Output:
; Function value - 1 on success; 0 on failure
; DGERR - defined on failure
;
N DGADT ;activity date ("ASSIGNDT")
N DGPFA ;assignment data array
N DGPFAH ;assignment history data array
N DGSET ;set id to represent a single PRF assignment
N CURASGN,DBRSCNT,DBRSNUM,RES
;
S DGSET=0 F S DGSET=$O(@DGORF@(DGSET)) Q:'DGSET D
.N DGPFA ;assignment data array
.;
.S DGPFA("DFN")=DGDFN
.S DGPFA("FLAG")=$G(@DGORF@(DGSET,"FLAG"))
.Q:DGPFA("FLAG")']""
.;prevent overwriting existing assignments
.S CURASGN=$$FNDASGN^DGPFAA(DGPFA("DFN"),DGPFA("FLAG")) Q:CURASGN
.;init STATUS as a placeholder, $$STATUS^DGPFUT sets value in loop
.S DGPFA("STATUS")=""
.S DGPFA("OWNER")=$G(@DGORF@(DGSET,"OWNER"))
.S DGPFA("ORIGSITE")=$G(@DGORF@(DGSET,"ORIGSITE"))
.M DGPFA("NARR")=@DGORF@(DGSET,"NARR")
.; DBRS data
.S DBRSCNT=0,DBRSNUM="" F S DBRSNUM=$O(@DGORF@(DGSET,"DBRS",DBRSNUM)) Q:DBRSNUM="" D
..S DBRSCNT=DBRSCNT+1
..S DGPFA("DBRS#",DBRSCNT)=DBRSNUM
..S DGPFA("DBRS OTHER",DBRSCNT)=$G(@DGORF@(DGSET,"DBRS",DBRSNUM,"OTHER"))
..S DGPFA("DBRS DATE",DBRSCNT)=$G(@DGORF@(DGSET,"DBRS",DBRSNUM,"DATE"))
..S DGPFA("DBRS ACTION",DBRSCNT)=$G(@DGORF@(DGSET,"DBRS",DBRSNUM,"ACTION"))
..S DGPFA("DBRS SITE",DBRSCNT)=$G(@DGORF@(DGSET,"DBRS",DBRSNUM,"SITE"))
..Q
.S DGADT=0 ;each DGADT represents a single PRF history action
.F S DGADT=$O(@DGORF@(DGSET,DGADT)) Q:'DGADT D Q:$D(DGERR)
..N DGPFAH ;assignment history data array
..;
..S DGPFAH("ASSIGNDT")=DGADT
..S DGPFAH("ACTION")=$G(@DGORF@(DGSET,DGADT,"ACTION"))
..S DGPFAH("ENTERBY")=.5 ;POSTMASTER
..S DGPFAH("APPRVBY")=.5 ;POSTMASTER
..M DGPFAH("COMMENT")=@DGORF@(DGSET,DGADT,"COMMENT")
..S DGPFAH("ORIGFAC")=$G(@DGORF@(DGSET,DGADT,"ORIGFAC"))
..; DBRS data
..S DBRSCNT=0,DBRSNUM="" F S DBRSNUM=$O(@DGORF@(DGSET,"DBRS",DBRSNUM)) Q:DBRSNUM="" D
...S DBRSCNT=DBRSCNT+1
...S DGPFAH("DBRS",DBRSCNT)=DBRSNUM_U_$G(@DGORF@(DGSET,"DBRS",DBRSNUM,"OTHER"))
...S DGPFAH("DBRS",DBRSCNT)=DGPFAH("DBRS",DBRSCNT)_U_$G(@DGORF@(DGSET,"DBRS",DBRSNUM,"DATE"))
...I $G(@DGORF@(DGSET,"DBRS",DBRSNUM,"ACTION"))="D" S DGPFAH("DBRS",DBRSCNT)=DGPFAH("DBRS",DBRSCNT)_U_"D" Q
...S DGPFAH("DBRS",DBRSCNT)=DGPFAH("DBRS",DBRSCNT)_U_"A"
...S DGPFAH("DBRS",DBRSCNT)=DGPFAH("DBRS",DBRSCNT)_U_$G(@DGORF@(DGSET,"DBRS",DBRSNUM,"SITE"))
...Q
..;calculate the assignment STATUS from the ACTION
..S DGPFA("STATUS")=$$STATUS^DGPFUT(DGPFAH("ACTION"))
..S RES=$$STOALL^DGPFAA(.DGPFA,.DGPFAH,.DGERR,"")
..Q
.Q
Q '$D(DGERR)
;
;call to $$PROD^XUPROD supported by ICR #4440
;
SDORUERR(DGMIEN,DGSEGERR,DGSTOERR,DGETYP) ;
N XMDUZ,XMSUB,XMTEXT,XMY,XMZ ;MailMan variables
N DGTXT,DGSTAT,DGCODE
S DGSTAT=$P($$SITE^VASITE,U,3)
S XMDUZ="PRF Error Processor"
S XMSUB="PRF Application Error (station #"_DGSTAT_")"
S XMSUB=XMSUB_" ["_$S($$PROD^XUPROD:"P",1:"T")_"]" ;production or test?
S XMY("G.DG PRF APPLICATION ERRORS")=""
I DGETYP="P" D
.D ERRMSGP(DGMIEN,.DGSEGERR,.DGTXT)
I DGETYP="S" D
.S DGTXT(1)="A store error occurred."
.S DGCODE=$G(DGSTOERR("DIERR",1))
.S:$L(DGCODE)>0 DGTXT(2)="The error code is "_DGCODE_"."
S XMTEXT="DGTXT("
D ^XMD
Q
;
ERRMSGP(DGMIEN,DGERR,DGTXT) ;
N DGLC,DGSEG,DGFLD,DGE,DGI,DGJ,DGK,DGEMSG
S DGLC=1
S DGTXT(DGLC)="One or more parse errors occurred in message #"_DGMIEN_"."
S DGI="" F S DGI=$O(DGERR(DGI)) Q:DGI="" D
.S DGSEG=DGI ;segment name
.S DGJ="" F S DGJ=$O(DGERR(DGI,DGJ)) Q:DGJ="" D
..S DGK="" F S DGK=$O(DGERR(DGI,DGJ,DGK)) Q:DGK="" D
...S DGFLD=DGK
...S DGE=$G(DGERR(DGI,DGJ,DGK))
...S DGEMSG="Error #"_DGE_" occurred in "_DGSEG_"-"_DGFLD
...S DGLC=DGLC+1,DGTXT(DGLC)=DGEMSG_"."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPFHLR 13424 printed Apr 09, 2024@21:44:25 Page 2
DGPFHLR ;ALB/RPM - PRF HL7 RECEIVE DRIVERS ; 8/14/06 12:01pm
+1 ;;5.3;Registration;**425,650,951,1005**;Aug 13, 1993;Build 57
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
RCV ;Receive all message types and route to message specific receiver
+1 ;
+2 ;This procedure is the main driver entry point for receiving all
+3 ;message types (ORU, ACK, QRY and ORF) for patient record flag
+4 ;assignment sharing.
+5 ;
+6 ;All procedures and functions assume that all VistA HL7 environment
+7 ;variables are properly initialized and will produce a fatal error if
+8 ;they are missing.
+9 ;
+10 ;The received message is copied to a temporary work global for
+11 ;processing. The message type is determined from the MSH segment and
+12 ;a receive processing procedure specific to the message type is called.
+13 ;(Ex. ORU~R01 message calls procedure: RCVORU). The specific receive
+14 ;processing procedure calls a message specific parse procedure to
+15 ;validate the message data and return data arrays for storage. If no
+16 ;parse errors are reported during validation, then the data arrays are
+17 ;stored by the receive processing procedure. Control, along with any
+18 ;parse validation errors, is then passed to the message specific send
+19 ;processing procedures to build and transmit the acknowledgment and
+20 ;query results messages.
+21 ;
+22 ; The message specific procedures are as follows:
+23 ;
+24 ; Message Receive Procedure Parse Procedure Send Procedure
+25 ; ------- ----------------- ---------------- --------------
+26 ; ORU~R01 RCVORU^DGPFHLR PARSORU^DGPFHLU SNDACK^DGPFHLS
+27 ; ACK~R01 RCVACK^DGPFHLR PARSACK^DGPFHLU4 N/A
+28 ; QRY~R02 RCVQRY^DGPFHLR PARSQRY^DGPFHLQ3 SNDORF^DGPFHLS
+29 ; ORF~R04 RCVORF^DGPFHLR PARSORF^DGPFHLQ3 N/A
+30 ;
+31 NEW DGCNT
+32 NEW DGMSGTYP
+33 NEW DGSEG
+34 NEW DGSEGCNT
+35 NEW DGWRK
+36 ;
+37 SET DGWRK=$NAME(^TMP("DGPFHL7",$JOB))
+38 KILL @DGWRK
+39 ;
+40 ;load work global with segments
+41 FOR DGSEGCNT=1:1
XECUTE HLNEXT
if HLQUIT'>0
QUIT
Begin DoDot:1
+42 SET DGCNT=0
+43 SET @DGWRK@(DGSEGCNT,DGCNT)=HLNODE
+44 FOR
SET DGCNT=$ORDER(HLNODE(DGCNT))
if 'DGCNT
QUIT
Begin DoDot:2
+45 SET @DGWRK@(DGSEGCNT,DGCNT)=HLNODE(DGCNT)
End DoDot:2
End DoDot:1
+46 ;
+47 ;get message type from "MSH"
+48 IF $$NXTSEG^DGPFHLUT(DGWRK,0,HL("FS"),.DGSEG)
IF $GET(DGSEG("TYPE"))="MSH"
Begin DoDot:1
+49 SET DGMSGTYP=$PIECE(DGSEG(9),$EXTRACT(HL("ECH"),1),1)
+50 ;HLMTIENS is only required by RCVORU and RCVQRY, thus $GET
+51 IF DGMSGTYP=HL("MTN")
DO @("RCV"_DGMSGTYP_"(DGWRK,$G(HLMTIENS),.HL)")
End DoDot:1
+52 ;
+53 ;cleanup
+54 KILL @DGWRK
+55 QUIT
+56 ;
RCVORU(DGWRK,DGMIEN,DGHL) ;Receive ORU Message Types (ORU~R01)
+1 ;
+2 ; Input:
+3 ; DGWRK - name of work global containing segments
+4 ; DGMIEN - IEN of message entry in file #773
+5 ; DGHL - HL environment array
+6 ;
+7 ; Output:
+8 ; none
+9 ;
+10 NEW DGORU
+11 ;segment error array
NEW DGSEGERR
+12 ;store error array
NEW DGSTOERR
+13 NEW DGACKTYP
+14 ;
+15 SET DGORU=$NAME(^TMP("DGPF",$JOB))
+16 KILL @DGORU
+17 DO PARSORU^DGPFHLU(DGWRK,.DGHL,DGORU,.DGSEGERR)
+18 ;parse error
IF $DATA(DGSEGERR)
DO SDORUERR(DGMIEN,.DGSEGERR,.DGSTOERR,"P")
+19 ;
+20 IF '$DATA(DGSEGERR)
IF $$STOORU(DGORU,.DGSTOERR)
Begin DoDot:1
+21 SET DGACKTYP="AA"
End DoDot:1
+22 IF '$TEST
Begin DoDot:1
+23 SET DGACKTYP="AE"
End DoDot:1
+24 ;
+25 ;store error
IF $DATA(DGSTOERR)
DO SDORUERR(DGMIEN,.DGSEGERR,.DGSTOERR,"S")
+26 DO SNDACK^DGPFHLS(DGACKTYP,DGMIEN,.DGHL,.DGSEGERR,.DGSTOERR)
+27 ;
+28 ;cleanup
+29 KILL @DGORU
+30 QUIT
+31 ;
STOORU(DGORU,DGERR) ;store ORU data array
+1 ;
+2 ; Input:
+3 ; DGORU - parsed ORU segment data array
+4 ;
+5 ; Output:
+6 ; Function value - 1 on success; 0 on failure
+7 ; DGERR - defined on failure
+8 ;
+9 ;assignment date
NEW DGADT
+10 ;count of assignment histories sent
NEW DGCNT
+11 ;assignment data array
NEW DGPFA
+12 ;assignment history data array
NEW DGPFAH
+13 ;flag to indicate a single history update
NEW DGSINGLE
+14 NEW CURASGN,DBRSCNT,DBRSNUM,LASTDT,RES,STOFLG
+15 ;
+16 ;
+17 SET DGPFA("SNDFAC")=$GET(@DGORU@("SNDFAC"))
+18 SET DGPFA("DFN")=$GET(@DGORU@("DFN"))
+19 SET DGPFA("FLAG")=$GET(@DGORU@("FLAG"))
+20 ;
+21 ;init STATUS as a placeholder, $$STATUS^DGPFUT sets value in loop
+22 SET DGPFA("STATUS")=""
+23 SET DGPFA("OWNER")=$GET(@DGORU@("OWNER"))
+24 SET DGPFA("ORIGSITE")=$GET(@DGORU@("ORIGSITE"))
+25 MERGE DGPFA("NARR")=@DGORU@("NARR")
+26 ; DBRS data
+27 SET DBRSCNT=0
SET DBRSNUM=""
FOR
SET DBRSNUM=$ORDER(@DGORU@("DBRS",DBRSNUM))
if DBRSNUM=""
QUIT
Begin DoDot:1
+28 SET DBRSCNT=DBRSCNT+1
+29 SET DGPFA("DBRS#",DBRSCNT)=DBRSNUM
+30 SET DGPFA("DBRS OTHER",DBRSCNT)=$GET(@DGORU@("DBRS",DBRSNUM,"OTHER"))
+31 SET DGPFA("DBRS DATE",DBRSCNT)=$GET(@DGORU@("DBRS",DBRSNUM,"DATE"))
+32 SET DGPFA("DBRS ACTION",DBRSCNT)=$GET(@DGORU@("DBRS",DBRSNUM,"ACTION"))
+33 SET DGPFA("DBRS SITE",DBRSCNT)=$GET(@DGORU@("DBRS",DBRSNUM,"SITE"))
+34 QUIT
End DoDot:1
+35 ;count number of assignment histories sent
+36 SET (DGADT,DGCNT)=0
+37 FOR
SET DGADT=$ORDER(@DGORU@(DGADT))
if 'DGADT
QUIT
SET DGCNT=DGCNT+1
+38 SET DGSINGLE=$SELECT(DGCNT>1:0,1:1)
+39 SET DGADT=0
+40 ; date of last history record
SET LASTDT=+$ORDER(@DGORU@(9999999.999999),-1)
+41 ;
+42 ;process only the last history action when assignment already exists
+43 SET CURASGN=$$FNDASGN^DGPFAA(DGPFA("DFN"),DGPFA("FLAG"))
+44 IF 'DGSINGLE
IF CURASGN
SET DGADT=LASTDT
SET DGSINGLE=1
+45 ;
+46 FOR
SET DGADT=$ORDER(@DGORU@(DGADT))
if 'DGADT
QUIT
Begin DoDot:1
+47 ;assignment history data array
NEW DGPFAH
+48 ;
+49 SET DGPFAH("ASSIGNDT")=DGADT
+50 SET DGPFAH("ACTION")=$GET(@DGORU@(DGADT,"ACTION"))
+51 ;POSTMASTER
SET DGPFAH("ENTERBY")=.5
+52 ;POSTMASTER
SET DGPFAH("APPRVBY")=.5
+53 MERGE DGPFAH("COMMENT")=@DGORU@(DGADT,"COMMENT")
+54 SET DGPFAH("ORIGFAC")=$GET(@DGORU@(DGADT,"ORIGFAC"))
+55 ; DBRS data
+56 SET DBRSCNT=0
SET DBRSNUM=""
FOR
SET DBRSNUM=$ORDER(@DGORU@("DBRS",DBRSNUM))
if DBRSNUM=""
QUIT
Begin DoDot:2
+57 SET DBRSCNT=DBRSCNT+1
+58 SET DGPFAH("DBRS",DBRSCNT)=DBRSNUM_U_$GET(@DGORU@("DBRS",DBRSNUM,"OTHER"))_U_$GET(@DGORU@("DBRS",DBRSNUM,"DATE"))
+59 IF $GET(@DGORU@("DBRS",DBRSNUM,"ACTION"))="U"
Begin DoDot:3
+60 SET RES=$$FIND1^DIC(26.131,","_CURASGN_",","X",DBRSNUM)
+61 SET DGPFAH("DBRS",DBRSCNT)=DGPFAH("DBRS",DBRSCNT)_U_$SELECT(RES:"E",1:"A")
+62 QUIT
End DoDot:3
+63 IF $GET(@DGORU@("DBRS",DBRSNUM,"ACTION"))="D"
SET DGPFAH("DBRS",DBRSCNT)=DGPFAH("DBRS",DBRSCNT)_U_"D"
+64 SET DGPFAH("DBRS",DBRSCNT)=DGPFAH("DBRS",DBRSCNT)_U_$GET(@DGORU@("DBRS",DBRSNUM,"SITE"))
+65 QUIT
End DoDot:2
+66 ; calculate the assignment STATUS from the ACTION
+67 SET DGPFA("STATUS")=$$STATUS^DGPFUT(DGPFAH("ACTION"))
+68 ; calculate new review date if this is ownership transfer
+69 ; if action = "continue" and current owner on file is different from owner in HL7 message, then it's an ownership transfer
+70 IF DGPFAH("ACTION")=2
IF $$GET1^DIQ(26.13,CURASGN_",",.04,"I")'=DGPFA("OWNER")
Begin DoDot:2
+71 ; if local site or division is the new owner, set review date
+72 IF DGPFA("OWNER")=$PIECE($$SITE^VASITE(),U)!$$ISDIV^DGPFUT(DGPFA("OWNER"))
Begin DoDot:3
+73 SET DGPFA("REVIEWDT")=$$GETRDT^DGPFAA3($PIECE(DGPFA("FLAG"),U),DGPFAH("ASSIGNDT"))
+74 QUIT
End DoDot:3
+75 QUIT
End DoDot:2
+76 ; find out if we want to overwrite existing DBRS data
+77 SET STOFLG=""
IF DGADT=LASTDT
IF "^2^4^5^7^8^"[(U_DGPFAH("ACTION")_U)
SET STOFLG="D"
+78 ;validate before filing for single updates and new assignments
+79 IF DGSINGLE!(DGPFAH("ACTION")=1)
SET RES=$$STOHL7^DGPFAA3(.DGPFA,.DGPFAH,"DGERR",STOFLG)
QUIT
+80 ;otherwise, just file it
+81 SET RES=$$STOALL^DGPFAA(.DGPFA,.DGPFAH,.DGERR,STOFLG)
+82 QUIT
End DoDot:1
if $DATA(DGERR)
QUIT
+83 ;convert dialog to dialog code
+84 IF $DATA(DGERR)
SET DGERR=$GET(DGERR("DIERR",1))
+85 ;
+86 QUIT '$DATA(DGERR)
+87 ;
RCVACK(DGWRK,DGMIEN,DGHL) ;Receive ACK Message Types (ACK~R01)
+1 ;
+2 ; Input:
+3 ; DGWRK - name of work global containing segments
+4 ; DGMIEN - IEN of message entry in file #773
+5 ; DGHL - HL environment array
+6 ;
+7 ; Output:
+8 ; none
+9 ;
+10 ;ACK data array
NEW DGACK
+11 ;error array
NEW DGERR
+12 ;HL7 transmission log IEN
NEW DGLIEN
+13 ;
+14 DO PARSACK^DGPFHLU4(DGWRK,.DGHL,.DGACK,.DGERR)
+15 SET DGLIEN=$$FNDLOG^DGPFHLL(26.17,$GET(DGACK("MSGID")))
+16 if 'DGLIEN
QUIT
+17 ;
+18 IF $GET(DGACK("ACKCODE"))="AA"
Begin DoDot:1
+19 DO STOSTAT^DGPFHLL(26.17,DGLIEN,"A",.DGERR)
End DoDot:1
+20 IF '$TEST
Begin DoDot:1
+21 ;update transmission log status (REJECTED) and process error
+22 DO STOSTAT^DGPFHLL(26.17,DGLIEN,"RJ",.DGERR)
+23 DO PROCERR^DGPFHLU5(DGLIEN,.DGACK,.DGERR)
End DoDot:1
+24 QUIT
+25 ;
RCVQRY(DGWRK,DGMIEN,DGHL) ;Receive QRY Message Types (QRY~R02)
+1 ;
+2 ; Input:
+3 ; DGWRK - name of work global containing segments
+4 ; DGMIEN - IEN of message entry in file #773
+5 ; DGHL - HL environment array
+6 ;
+7 ; Output:
+8 ; none
+9 ;
+10 NEW DGDFN
+11 NEW DGDFNERR
+12 NEW DGQRY
+13 NEW DGQRYERR
+14 NEW DGSEGERR
+15 ;
+16 DO PARSQRY^DGPFHLQ3(DGWRK,.DGHL,.DGQRY,.DGSEGERR)
+17 SET DGDFN=$$GETDFN^DGPFUT2(DGQRY("ICN"),"DGDFNERR")
+18 IF DGDFN'>0
IF $GET(DGDFNERR("DIERR",1))]""
Begin DoDot:1
+19 SET DGQRYERR=DGDFNERR("DIERR",1)
End DoDot:1
+20 DO SNDORF^DGPFHLS(.DGQRY,DGMIEN,.DGHL,DGDFN,.DGSEGERR,.DGQRYERR)
+21 QUIT
+22 ;
RCVORF(DGWRK,DGMIEN,DGHL) ;Receive ORF Message Types (ORF~R04)
+1 ;
+2 ; Input:
+3 ; DGWRK - name of work global containing segments
+4 ; DGMIEN - IEN of message entry in file #773
+5 ; DGHL - HL environment array
+6 ;
+7 ; Output:
+8 ; none
+9 ;
+10 ;pointer to PATIENT (#2) file
NEW DGDFN
+11 ;HL7 query log IEN
NEW DGLIEN
+12 ;ORF data array root
NEW DGORF
+13 ;parser error array
NEW DGERR
+14 ;query log status
NEW DGSTAT
+15 ;
+16 SET DGORF=$NAME(^TMP("DGPF",$JOB))
+17 KILL @DGORF
+18 DO PARSORF^DGPFHLQ4(DGWRK,.DGHL,DGORF,.DGERR)
+19 SET DGDFN=+$$GETDFN^MPIF001($GET(@DGORF@("ICN")))
+20 ;
+21 ;successful query
+22 IF $GET(@DGORF@("ACKCODE"))="AA"
Begin DoDot:1
+23 SET DGSTAT=$SELECT(+$ORDER(@DGORF@(0))>0:"A",1:"AN")
+24 ;
+25 ;REJECT when filer fails; otherwise mark event as COMPLETE
+26 IF '$$STOORF(DGDFN,DGORF)
Begin DoDot:2
+27 SET DGSTAT="RJ"
+28 ;Unable to file
SET DGERR($ORDER(DGERR(""),-1)+1)=261120
End DoDot:2
+29 IF '$TEST
DO STOEVNT^DGPFHLL1(DGDFN,"C")
End DoDot:1
+30 ;
+31 ;failed query
+32 IF $GET(@DGORF@("ACKCODE"))'="AA"
SET DGSTAT="RJ"
+33 ;
+34 ;find and update query log status
+35 SET DGLIEN=$$FNDLOG^DGPFHLL(26.19,$GET(@DGORF@("MSGID")))
+36 IF DGLIEN
DO STOSTAT^DGPFHLL(26.19,DGLIEN,DGSTAT,.DGERR)
+37 ;
+38 ;purge PRF HL7 QUERY LOG when status is COMPLETE
+39 IF $$GETSTAT^DGPFHLL1(DGDFN)="C"
DO PRGQLOG^DGPFHLL($$FNDEVNT^DGPFHLL1(DGDFN))
+40 ;
+41 ;cleanup
+42 KILL @DGORF
+43 QUIT
+44 ;
STOORF(DGDFN,DGORF,DGERR) ;store ORF data
+1 ;
+2 ; Input:
+3 ; DGDFN - pointer to patient in PATIENT (#2) file
+4 ; DGORF - parsed ORF segments data array
+5 ;
+6 ; Output:
+7 ; Function value - 1 on success; 0 on failure
+8 ; DGERR - defined on failure
+9 ;
+10 ;activity date ("ASSIGNDT")
NEW DGADT
+11 ;assignment data array
NEW DGPFA
+12 ;assignment history data array
NEW DGPFAH
+13 ;set id to represent a single PRF assignment
NEW DGSET
+14 NEW CURASGN,DBRSCNT,DBRSNUM,RES
+15 ;
+16 SET DGSET=0
FOR
SET DGSET=$ORDER(@DGORF@(DGSET))
if 'DGSET
QUIT
Begin DoDot:1
+17 ;assignment data array
NEW DGPFA
+18 ;
+19 SET DGPFA("DFN")=DGDFN
+20 SET DGPFA("FLAG")=$GET(@DGORF@(DGSET,"FLAG"))
+21 if DGPFA("FLAG")']""
QUIT
+22 ;prevent overwriting existing assignments
+23 SET CURASGN=$$FNDASGN^DGPFAA(DGPFA("DFN"),DGPFA("FLAG"))
if CURASGN
QUIT
+24 ;init STATUS as a placeholder, $$STATUS^DGPFUT sets value in loop
+25 SET DGPFA("STATUS")=""
+26 SET DGPFA("OWNER")=$GET(@DGORF@(DGSET,"OWNER"))
+27 SET DGPFA("ORIGSITE")=$GET(@DGORF@(DGSET,"ORIGSITE"))
+28 MERGE DGPFA("NARR")=@DGORF@(DGSET,"NARR")
+29 ; DBRS data
+30 SET DBRSCNT=0
SET DBRSNUM=""
FOR
SET DBRSNUM=$ORDER(@DGORF@(DGSET,"DBRS",DBRSNUM))
if DBRSNUM=""
QUIT
Begin DoDot:2
+31 SET DBRSCNT=DBRSCNT+1
+32 SET DGPFA("DBRS#",DBRSCNT)=DBRSNUM
+33 SET DGPFA("DBRS OTHER",DBRSCNT)=$GET(@DGORF@(DGSET,"DBRS",DBRSNUM,"OTHER"))
+34 SET DGPFA("DBRS DATE",DBRSCNT)=$GET(@DGORF@(DGSET,"DBRS",DBRSNUM,"DATE"))
+35 SET DGPFA("DBRS ACTION",DBRSCNT)=$GET(@DGORF@(DGSET,"DBRS",DBRSNUM,"ACTION"))
+36 SET DGPFA("DBRS SITE",DBRSCNT)=$GET(@DGORF@(DGSET,"DBRS",DBRSNUM,"SITE"))
+37 QUIT
End DoDot:2
+38 ;each DGADT represents a single PRF history action
SET DGADT=0
+39 FOR
SET DGADT=$ORDER(@DGORF@(DGSET,DGADT))
if 'DGADT
QUIT
Begin DoDot:2
+40 ;assignment history data array
NEW DGPFAH
+41 ;
+42 SET DGPFAH("ASSIGNDT")=DGADT
+43 SET DGPFAH("ACTION")=$GET(@DGORF@(DGSET,DGADT,"ACTION"))
+44 ;POSTMASTER
SET DGPFAH("ENTERBY")=.5
+45 ;POSTMASTER
SET DGPFAH("APPRVBY")=.5
+46 MERGE DGPFAH("COMMENT")=@DGORF@(DGSET,DGADT,"COMMENT")
+47 SET DGPFAH("ORIGFAC")=$GET(@DGORF@(DGSET,DGADT,"ORIGFAC"))
+48 ; DBRS data
+49 SET DBRSCNT=0
SET DBRSNUM=""
FOR
SET DBRSNUM=$ORDER(@DGORF@(DGSET,"DBRS",DBRSNUM))
if DBRSNUM=""
QUIT
Begin DoDot:3
+50 SET DBRSCNT=DBRSCNT+1
+51 SET DGPFAH("DBRS",DBRSCNT)=DBRSNUM_U_$GET(@DGORF@(DGSET,"DBRS",DBRSNUM,"OTHER"))
+52 SET DGPFAH("DBRS",DBRSCNT)=DGPFAH("DBRS",DBRSCNT)_U_$GET(@DGORF@(DGSET,"DBRS",DBRSNUM,"DATE"))
+53 IF $GET(@DGORF@(DGSET,"DBRS",DBRSNUM,"ACTION"))="D"
SET DGPFAH("DBRS",DBRSCNT)=DGPFAH("DBRS",DBRSCNT)_U_"D"
QUIT
+54 SET DGPFAH("DBRS",DBRSCNT)=DGPFAH("DBRS",DBRSCNT)_U_"A"
+55 SET DGPFAH("DBRS",DBRSCNT)=DGPFAH("DBRS",DBRSCNT)_U_$GET(@DGORF@(DGSET,"DBRS",DBRSNUM,"SITE"))
+56 QUIT
End DoDot:3
+57 ;calculate the assignment STATUS from the ACTION
+58 SET DGPFA("STATUS")=$$STATUS^DGPFUT(DGPFAH("ACTION"))
+59 SET RES=$$STOALL^DGPFAA(.DGPFA,.DGPFAH,.DGERR,"")
+60 QUIT
End DoDot:2
if $DATA(DGERR)
QUIT
+61 QUIT
End DoDot:1
+62 QUIT '$DATA(DGERR)
+63 ;
+64 ;call to $$PROD^XUPROD supported by ICR #4440
+65 ;
SDORUERR(DGMIEN,DGSEGERR,DGSTOERR,DGETYP) ;
+1 ;MailMan variables
NEW XMDUZ,XMSUB,XMTEXT,XMY,XMZ
+2 NEW DGTXT,DGSTAT,DGCODE
+3 SET DGSTAT=$PIECE($$SITE^VASITE,U,3)
+4 SET XMDUZ="PRF Error Processor"
+5 SET XMSUB="PRF Application Error (station #"_DGSTAT_")"
+6 ;production or test?
SET XMSUB=XMSUB_" ["_$SELECT($$PROD^XUPROD:"P",1:"T")_"]"
+7 SET XMY("G.DG PRF APPLICATION ERRORS")=""
+8 IF DGETYP="P"
Begin DoDot:1
+9 DO ERRMSGP(DGMIEN,.DGSEGERR,.DGTXT)
End DoDot:1
+10 IF DGETYP="S"
Begin DoDot:1
+11 SET DGTXT(1)="A store error occurred."
+12 SET DGCODE=$GET(DGSTOERR("DIERR",1))
+13 if $LENGTH(DGCODE)>0
SET DGTXT(2)="The error code is "_DGCODE_"."
End DoDot:1
+14 SET XMTEXT="DGTXT("
+15 DO ^XMD
+16 QUIT
+17 ;
ERRMSGP(DGMIEN,DGERR,DGTXT) ;
+1 NEW DGLC,DGSEG,DGFLD,DGE,DGI,DGJ,DGK,DGEMSG
+2 SET DGLC=1
+3 SET DGTXT(DGLC)="One or more parse errors occurred in message #"_DGMIEN_"."
+4 SET DGI=""
FOR
SET DGI=$ORDER(DGERR(DGI))
if DGI=""
QUIT
Begin DoDot:1
+5 ;segment name
SET DGSEG=DGI
+6 SET DGJ=""
FOR
SET DGJ=$ORDER(DGERR(DGI,DGJ))
if DGJ=""
QUIT
Begin DoDot:2
+7 SET DGK=""
FOR
SET DGK=$ORDER(DGERR(DGI,DGJ,DGK))
if DGK=""
QUIT
Begin DoDot:3
+8 SET DGFLD=DGK
+9 SET DGE=$GET(DGERR(DGI,DGJ,DGK))
+10 SET DGEMSG="Error #"_DGE_" occurred in "_DGSEG_"-"_DGFLD
+11 SET DGLC=DGLC+1
SET DGTXT(DGLC)=DGEMSG_"."
End DoDot:3
End DoDot:2
End DoDot:1
+12 QUIT
