DGPFHLR ;ALB/RPM - PRF HL7 RECEIVE DRIVERS ; 8/14/06 12:01pm
;;5.3;Registration;**425,650,1015**;Aug 13, 1993;Build 21
;
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
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),$$STOORU(DGORU,.DGSTOERR) D
. S DGACKTYP="AA"
E D
. S DGACKTYP="AE"
;
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
;
;
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")
;
;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
;
;process only the last history action when assignment already exists
I 'DGSINGLE,$$FNDASGN^DGPFAA(DGPFA("DFN"),DGPFA("FLAG")) D
. S DGADT=+$O(@DGORU@($O(@DGORU@(9999999.999999),-1)),-1)
. S 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")
. ;
. ;calculate the assignment STATUS from the ACTION
. S DGPFA("STATUS")=$$STATUS^DGPFUT(DGPFAH("ACTION"))
. ;validate before filing for single updates and new assignments
. I DGSINGLE!(DGPFAH("ACTION")=1) D
. . I $$STOHL7^DGPFAA3(.DGPFA,.DGPFAH,"DGERR")
. ;otherwise, just file it
. E D
. . I $$STOALL^DGPFAA(.DGPFA,.DGPFAH,.DGERR)
;
;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
;
;
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
. Q:$$FNDASGN^DGPFAA(DGPFA("DFN"),DGPFA("FLAG"))
. ;
. ;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")
. 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")
. . ;
. . ;calculate the assignment STATUS from the ACTION
. . S DGPFA("STATUS")=$$STATUS^DGPFUT(DGPFAH("ACTION"))
. . I $$STOALL^DGPFAA(.DGPFA,.DGPFAH,.DGERR)
Q '$D(DGERR)
DGPFHLR ;ALB/RPM - PRF HL7 RECEIVE DRIVERS ; 8/14/06 12:01pm
+1 ;;5.3;Registration;**425,650,1015**;Aug 13, 1993;Build 21
+2 ;
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 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 ;
+19 IF '$DATA(DGSEGERR)
IF $$STOORU(DGORU,.DGSTOERR)
Begin DoDot:1
+20 SET DGACKTYP="AA"
End DoDot:1
+21 IF '$TEST
Begin DoDot:1
+22 SET DGACKTYP="AE"
End DoDot:1
+23 ;
+24 DO SNDACK^DGPFHLS(DGACKTYP,DGMIEN,.DGHL,.DGSEGERR,.DGSTOERR)
+25 ;
+26 ;cleanup
+27 KILL @DGORU
+28 QUIT
+29 ;
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 ;
+15 ;
+16 SET DGPFA("SNDFAC")=$GET(@DGORU@("SNDFAC"))
+17 SET DGPFA("DFN")=$GET(@DGORU@("DFN"))
+18 SET DGPFA("FLAG")=$GET(@DGORU@("FLAG"))
+19 ;
+20 ;init STATUS as a placeholder, $$STATUS^DGPFUT sets value in loop
+21 SET DGPFA("STATUS")=""
+22 SET DGPFA("OWNER")=$GET(@DGORU@("OWNER"))
+23 SET DGPFA("ORIGSITE")=$GET(@DGORU@("ORIGSITE"))
+24 MERGE DGPFA("NARR")=@DGORU@("NARR")
+25 ;
+26 ;count number of assignment histories sent
+27 SET (DGADT,DGCNT)=0
+28 FOR
SET DGADT=$ORDER(@DGORU@(DGADT))
IF 'DGADT
QUIT
SET DGCNT=DGCNT+1
+29 SET DGSINGLE=$SELECT(DGCNT>1:0,1:1)
+30 SET DGADT=0
+31 ;
+32 ;process only the last history action when assignment already exists
+33 IF 'DGSINGLE
IF $$FNDASGN^DGPFAA(DGPFA("DFN"),DGPFA("FLAG"))
Begin DoDot:1
+34 SET DGADT=+$ORDER(@DGORU@($ORDER(@DGORU@(9999999.999999),-1)),-1)
+35 SET DGSINGLE=1
End DoDot:1
+36 ;
+37 FOR
SET DGADT=$ORDER(@DGORU@(DGADT))
IF 'DGADT
QUIT
Begin DoDot:1
+38 ;assignment history data array
NEW DGPFAH
+39 ;
+40 SET DGPFAH("ASSIGNDT")=DGADT
+41 SET DGPFAH("ACTION")=$GET(@DGORU@(DGADT,"ACTION"))
+42 ;POSTMASTER
SET DGPFAH("ENTERBY")=.5
+43 ;POSTMASTER
SET DGPFAH("APPRVBY")=.5
+44 MERGE DGPFAH("COMMENT")=@DGORU@(DGADT,"COMMENT")
+45 ;
+46 ;calculate the assignment STATUS from the ACTION
+47 SET DGPFA("STATUS")=$$STATUS^DGPFUT(DGPFAH("ACTION"))
+48 ;validate before filing for single updates and new assignments
+49 IF DGSINGLE!(DGPFAH("ACTION")=1)
Begin DoDot:2
+50 IF $$STOHL7^DGPFAA3(.DGPFA,.DGPFAH,"DGERR")
End DoDot:2
+51 ;otherwise, just file it
+52 IF '$TEST
Begin DoDot:2
+53 IF $$STOALL^DGPFAA(.DGPFA,.DGPFAH,.DGERR)
End DoDot:2
End DoDot:1
IF $DATA(DGERR)
QUIT
+54 ;
+55 ;convert dialog to dialog code
+56 IF $DATA(DGERR)
SET DGERR=$GET(DGERR("DIERR",1))
+57 ;
+58 QUIT '$DATA(DGERR)
+59 ;
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 ;
+15 ;
+16 SET DGSET=0
+17 FOR
SET DGSET=$ORDER(@DGORF@(DGSET))
IF 'DGSET
QUIT
Begin DoDot:1
+18 ;assignment data array
NEW DGPFA
+19 ;
+20 SET DGPFA("DFN")=DGDFN
+21 SET DGPFA("FLAG")=$GET(@DGORF@(DGSET,"FLAG"))
+22 IF DGPFA("FLAG")']""
QUIT
+23 ;
+24 ;prevent overwriting existing assignments
+25 IF $$FNDASGN^DGPFAA(DGPFA("DFN"),DGPFA("FLAG"))
QUIT
+26 ;
+27 ;init STATUS as a placeholder, $$STATUS^DGPFUT sets value in loop
+28 SET DGPFA("STATUS")=""
+29 SET DGPFA("OWNER")=$GET(@DGORF@(DGSET,"OWNER"))
+30 SET DGPFA("ORIGSITE")=$GET(@DGORF@(DGSET,"ORIGSITE"))
+31 MERGE DGPFA("NARR")=@DGORF@(DGSET,"NARR")
+32 ;each DGADT represents a single PRF history action
SET DGADT=0
+33 FOR
SET DGADT=$ORDER(@DGORF@(DGSET,DGADT))
IF 'DGADT
QUIT
Begin DoDot:2
+34 ;assignment history data array
NEW DGPFAH
+35 ;
+36 SET DGPFAH("ASSIGNDT")=DGADT
+37 SET DGPFAH("ACTION")=$GET(@DGORF@(DGSET,DGADT,"ACTION"))
+38 ;POSTMASTER
SET DGPFAH("ENTERBY")=.5
+39 ;POSTMASTER
SET DGPFAH("APPRVBY")=.5
+40 MERGE DGPFAH("COMMENT")=@DGORF@(DGSET,DGADT,"COMMENT")
+41 ;
+42 ;calculate the assignment STATUS from the ACTION
+43 SET DGPFA("STATUS")=$$STATUS^DGPFUT(DGPFAH("ACTION"))
+44 IF $$STOALL^DGPFAA(.DGPFA,.DGPFAH,.DGERR)
End DoDot:2
IF $DATA(DGERR)
QUIT
End DoDot:1
+45 QUIT '$DATA(DGERR)
