DGPFHLT3 ;SHRPE/YMG - PRF HL7 QBP/RSP PROCESSING ; 05/02/18
;;5.3;Registration;**951**;Aug 13, 1993;Build 135
;;Per VA Directive 6402, this routine should not be modified.
;
; This is the main driver for processing RSP^K11 (response to PRF flag transfer request) messages
;
Q
;
EN ; entry point
; called from EN^DGPFHLT1, uses ^TMP("DGPFHLT1,$J") work global created there.
;
N DGERR,DGFDA,DGFERR,ERTXT,IENS,LOGIEN,MAILARY,MAILPFA,MSGID,REQID,SEGCNT,SEGNM,SEGSTR,SNDFAC,STOP
;
S STOP=0,DGERR=""
; parse the message
S SEGCNT="" F S SEGCNT=$O(^TMP("DGPFHLT1",$J,SEGCNT)) Q:SEGCNT="" D Q:STOP
.S SEGSTR=$G(^TMP("DGPFHLT1",$J,SEGCNT,0))
.S SEGNM=$P(SEGSTR,HLFS)
.I SEGNM="MSH" D
..; parse MSH segment
..S SNDFAC=$P($P(SEGSTR,HLFS,4),HLCMP) ; sending facility (station #) for use in error messages
..S MSGID=$P(SEGSTR,HLFS,10) ; HL7 message Id
..Q
.I SEGNM="QAK" D Q:STOP
..; parse QAK segment
..S REQID=$P(SEGSTR,HLFS,2) ; query Id
..S LOGIEN=$$FNDLOG(REQID) I 'LOGIEN D Q
...S DGERR="Unable to find log entry for query id "_REQID
...D SENDERR(MSGID,SNDFAC,"",DGERR)
...S STOP=1
...Q
..S IENS=LOGIEN_","
..I DGERR="",$P(SEGSTR,HLFS,3)'="OK" S DGERR="Receiver was unable to find corresponding PRF flag assignment."
..Q
.I SEGNM="QPD" D
..; parse QPD segment
..S MAILARY("REVBY")=$$DECHL7^DGPFHLUT($P(SEGSTR,HLFS,6)) ; reviewer name
..S MAILARY("REVDTM")=$$FMDATE^HLFNC($P(SEGSTR,HLFS,7)) ; review date/time
..Q
.I SEGNM="NTE" D
..; parse NTE segment
..S MAILARY("REVRES")=$P($P(SEGSTR,HLFS,4),HLREP) ; result of the review
..S MAILARY("REVCMT")=$$DECHL7^DGPFHLUT($P($P(SEGSTR,HLFS,4),HLREP,2)) ; review reason
..Q
.Q
S MAILARY("REVRES")=$G(MAILARY("REVRES"))
I "^A^D^"'[(U_MAILARY("REVRES")_U),DGERR="" S DGERR="Invalid review status code received."
; send ACK message
D SEND^DGPFHLT4(MSGID,DGERR)
; update log entry
I $G(IENS) D UPDLOG(IENS,DGERR,.MAILARY,.DGFERR)
I DGERR'=""!$D(DGFERR) D G ENX
.; Send Mailman notification for error
.D:DGERR'="" SENDERR(MSGID,SNDFAC,"",DGERR)
.D:$D(DGFERR) SENDERR(MSGID,SNDFAC,$G(DGFERR("DIERR",1)),$G(DGFERR("DIERR",1,"TEXT",1)))
.Q
; finish setting up data structures for DGPFHLTM and send Mailman notification about response
K DGFDA D GETS^DIQ(26.22,IENS,".01:.04;2.01",,"DGFDA")
S MAILARY("REQDTM")=$G(DGFDA(26.22,IENS,.01))
S MAILARY("REQBY")=$G(DGFDA(26.22,IENS,.02))
S MAILARY("REQCMT")=$G(DGFDA(26.22,IENS,2.01))
; only set external values here for TREQMSG^DGPFHLTM, full DGPFA is not needed.
S MAILPFA("DFN")=U_$G(DGFDA(26.22,IENS,.03))
S MAILPFA("FLAG")=U_$G(DGFDA(26.22,IENS,.04))
D TREQMSG^DGPFHLTM(.MAILARY,.MAILPFA,2)
; update "NO RESPONSE" entries with new review date/time
D NORESPDT($$FIND1^DIC(2,,"X",$G(DGFDA(26.22,IENS,.03))),$$FIND1^DIC(26.15,,"X",$G(DGFDA(26.22,IENS,.04))),MAILARY("REVDTM"))
;
ENX ; exit point
K ^TMP("DGPFHLT1",$J)
Q
;
FNDLOG(REQID) ; find log entry (file 26.22) for a given query id
; REQID - query id to look for
; Returns ien in file 26.22 on success, 0 otherwise
N RES
S RES=0 I $G(REQID)'="" S RES=+$O(^DGPF(26.22,"C",REQID,""))
Q RES
;
SENDERR(MSGID,SNDFAC,DGECODE,DGERR) ; send Mailman notification for an error
N ERTXT
S ERTXT(1)="Error while processing RSP^K11 HL7 message from station # "_$G(SNDFAC)_"."
S ERTXT(3)="Error code: "_$S($G(DGECODE)="":"N/A",1:$G(DGECODE))
S ERTXT(4)="Error description: "_$G(DGERR)
D TERRMSG^DGPFHLTM(MSGID,.ERTXT)
Q
;
UPDLOG(IENS,DGERR,DATA,DGFERR) ; update log entry in file 26.22
; only updates fields .05,.06,.07,and 1
;
; IENS - ien in file 26.22_","
; DGERR - error text to file into 26.22/1
; DATA - array of values to file (see tag EN^DGPFHLT1)
; DGFERR - array to return FM filing errors in
;
; returns filing errors in DGFERR, if any.
;
N DGFDA
S DGFDA(26.22,IENS,.05)=$S(DGERR'="":5,DATA("REVRES")="A":3,1:4)
S DGFDA(26.22,IENS,.06)=$G(DATA("REVBY"))
S DGFDA(26.22,IENS,.07)=$G(DATA("REVDTM"))
S DGFDA(26.22,IENS,2.02)=$G(DATA("REVCMT"))
S:DGERR'="" DGFDA(26.22,IENS,1)=DGERR
D FILE^DIE(,"DGFDA","DGFERR")
Q
;
NORESPDT(DFN,FLAG,RDT) ; update review date/time of "NO RESPONSE" entries in file 26.22
; DFN - patient DFN
; FLAG - flag ien in file 26.15
; RDT - review date/time to use in internal FM format
;
N DATE,DGFDA,DIERR,IEN
I +DFN'>0!(+FLAG'>0) Q
; loop through "NO RESPONSE" entries
S DATE="" F S DATE=$O(^DGPF(26.22,"D",DFN,FLAG,6,DATE)) Q:DATE="" D
.S IEN=+$O(^DGPF(26.22,"D",DFN,FLAG,6,DATE,""))
.S DGFDA(26.22,IEN_",",.07)=RDT
.D FILE^DIE(,"DGFDA","DIERR") K DGFDA
.Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPFHLT3 4646 printed Sep 23, 2025@20:23:42 Page 2
DGPFHLT3 ;SHRPE/YMG - PRF HL7 QBP/RSP PROCESSING ; 05/02/18
+1 ;;5.3;Registration;**951**;Aug 13, 1993;Build 135
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; This is the main driver for processing RSP^K11 (response to PRF flag transfer request) messages
+5 ;
+6 QUIT
+7 ;
EN ; entry point
+1 ; called from EN^DGPFHLT1, uses ^TMP("DGPFHLT1,$J") work global created there.
+2 ;
+3 NEW DGERR,DGFDA,DGFERR,ERTXT,IENS,LOGIEN,MAILARY,MAILPFA,MSGID,REQID,SEGCNT,SEGNM,SEGSTR,SNDFAC,STOP
+4 ;
+5 SET STOP=0
SET DGERR=""
+6 ; parse the message
+7 SET SEGCNT=""
FOR
SET SEGCNT=$ORDER(^TMP("DGPFHLT1",$JOB,SEGCNT))
if SEGCNT=""
QUIT
Begin DoDot:1
+8 SET SEGSTR=$GET(^TMP("DGPFHLT1",$JOB,SEGCNT,0))
+9 SET SEGNM=$PIECE(SEGSTR,HLFS)
+10 IF SEGNM="MSH"
Begin DoDot:2
+11 ; parse MSH segment
+12 ; sending facility (station #) for use in error messages
SET SNDFAC=$PIECE($PIECE(SEGSTR,HLFS,4),HLCMP)
+13 ; HL7 message Id
SET MSGID=$PIECE(SEGSTR,HLFS,10)
+14 QUIT
End DoDot:2
+15 IF SEGNM="QAK"
Begin DoDot:2
+16 ; parse QAK segment
+17 ; query Id
SET REQID=$PIECE(SEGSTR,HLFS,2)
+18 SET LOGIEN=$$FNDLOG(REQID)
IF 'LOGIEN
Begin DoDot:3
+19 SET DGERR="Unable to find log entry for query id "_REQID
+20 DO SENDERR(MSGID,SNDFAC,"",DGERR)
+21 SET STOP=1
+22 QUIT
End DoDot:3
QUIT
+23 SET IENS=LOGIEN_","
+24 IF DGERR=""
IF $PIECE(SEGSTR,HLFS,3)'="OK"
SET DGERR="Receiver was unable to find corresponding PRF flag assignment."
+25 QUIT
End DoDot:2
if STOP
QUIT
+26 IF SEGNM="QPD"
Begin DoDot:2
+27 ; parse QPD segment
+28 ; reviewer name
SET MAILARY("REVBY")=$$DECHL7^DGPFHLUT($PIECE(SEGSTR,HLFS,6))
+29 ; review date/time
SET MAILARY("REVDTM")=$$FMDATE^HLFNC($PIECE(SEGSTR,HLFS,7))
+30 QUIT
End DoDot:2
+31 IF SEGNM="NTE"
Begin DoDot:2
+32 ; parse NTE segment
+33 ; result of the review
SET MAILARY("REVRES")=$PIECE($PIECE(SEGSTR,HLFS,4),HLREP)
+34 ; review reason
SET MAILARY("REVCMT")=$$DECHL7^DGPFHLUT($PIECE($PIECE(SEGSTR,HLFS,4),HLREP,2))
+35 QUIT
End DoDot:2
+36 QUIT
End DoDot:1
if STOP
QUIT
+37 SET MAILARY("REVRES")=$GET(MAILARY("REVRES"))
+38 IF "^A^D^"'[(U_MAILARY("REVRES")_U)
IF DGERR=""
SET DGERR="Invalid review status code received."
+39 ; send ACK message
+40 DO SEND^DGPFHLT4(MSGID,DGERR)
+41 ; update log entry
+42 IF $GET(IENS)
DO UPDLOG(IENS,DGERR,.MAILARY,.DGFERR)
+43 IF DGERR'=""!$DATA(DGFERR)
Begin DoDot:1
+44 ; Send Mailman notification for error
+45 if DGERR'=""
DO SENDERR(MSGID,SNDFAC,"",DGERR)
+46 if $DATA(DGFERR)
DO SENDERR(MSGID,SNDFAC,$GET(DGFERR("DIERR",1)),$GET(DGFERR("DIERR",1,"TEXT",1)))
+47 QUIT
End DoDot:1
GOTO ENX
+48 ; finish setting up data structures for DGPFHLTM and send Mailman notification about response
+49 KILL DGFDA
DO GETS^DIQ(26.22,IENS,".01:.04;2.01",,"DGFDA")
+50 SET MAILARY("REQDTM")=$GET(DGFDA(26.22,IENS,.01))
+51 SET MAILARY("REQBY")=$GET(DGFDA(26.22,IENS,.02))
+52 SET MAILARY("REQCMT")=$GET(DGFDA(26.22,IENS,2.01))
+53 ; only set external values here for TREQMSG^DGPFHLTM, full DGPFA is not needed.
+54 SET MAILPFA("DFN")=U_$GET(DGFDA(26.22,IENS,.03))
+55 SET MAILPFA("FLAG")=U_$GET(DGFDA(26.22,IENS,.04))
+56 DO TREQMSG^DGPFHLTM(.MAILARY,.MAILPFA,2)
+57 ; update "NO RESPONSE" entries with new review date/time
+58 DO NORESPDT($$FIND1^DIC(2,,"X",$GET(DGFDA(26.22,IENS,.03))),$$FIND1^DIC(26.15,,"X",$GET(DGFDA(26.22,IENS,.04))),MAILARY("REVDTM"))
+59 ;
ENX ; exit point
+1 KILL ^TMP("DGPFHLT1",$JOB)
+2 QUIT
+3 ;
FNDLOG(REQID) ; find log entry (file 26.22) for a given query id
+1 ; REQID - query id to look for
+2 ; Returns ien in file 26.22 on success, 0 otherwise
+3 NEW RES
+4 SET RES=0
IF $GET(REQID)'=""
SET RES=+$ORDER(^DGPF(26.22,"C",REQID,""))
+5 QUIT RES
+6 ;
SENDERR(MSGID,SNDFAC,DGECODE,DGERR) ; send Mailman notification for an error
+1 NEW ERTXT
+2 SET ERTXT(1)="Error while processing RSP^K11 HL7 message from station # "_$GET(SNDFAC)_"."
+3 SET ERTXT(3)="Error code: "_$SELECT($GET(DGECODE)="":"N/A",1:$GET(DGECODE))
+4 SET ERTXT(4)="Error description: "_$GET(DGERR)
+5 DO TERRMSG^DGPFHLTM(MSGID,.ERTXT)
+6 QUIT
+7 ;
UPDLOG(IENS,DGERR,DATA,DGFERR) ; update log entry in file 26.22
+1 ; only updates fields .05,.06,.07,and 1
+2 ;
+3 ; IENS - ien in file 26.22_","
+4 ; DGERR - error text to file into 26.22/1
+5 ; DATA - array of values to file (see tag EN^DGPFHLT1)
+6 ; DGFERR - array to return FM filing errors in
+7 ;
+8 ; returns filing errors in DGFERR, if any.
+9 ;
+10 NEW DGFDA
+11 SET DGFDA(26.22,IENS,.05)=$SELECT(DGERR'="":5,DATA("REVRES")="A":3,1:4)
+12 SET DGFDA(26.22,IENS,.06)=$GET(DATA("REVBY"))
+13 SET DGFDA(26.22,IENS,.07)=$GET(DATA("REVDTM"))
+14 SET DGFDA(26.22,IENS,2.02)=$GET(DATA("REVCMT"))
+15 if DGERR'=""
SET DGFDA(26.22,IENS,1)=DGERR
+16 DO FILE^DIE(,"DGFDA","DGFERR")
+17 QUIT
+18 ;
NORESPDT(DFN,FLAG,RDT) ; update review date/time of "NO RESPONSE" entries in file 26.22
+1 ; DFN - patient DFN
+2 ; FLAG - flag ien in file 26.15
+3 ; RDT - review date/time to use in internal FM format
+4 ;
+5 NEW DATE,DGFDA,DIERR,IEN
+6 IF +DFN'>0!(+FLAG'>0)
QUIT
+7 ; loop through "NO RESPONSE" entries
+8 SET DATE=""
FOR
SET DATE=$ORDER(^DGPF(26.22,"D",DFN,FLAG,6,DATE))
if DATE=""
QUIT
Begin DoDot:1
+9 SET IEN=+$ORDER(^DGPF(26.22,"D",DFN,FLAG,6,DATE,""))
+10 SET DGFDA(26.22,IEN_",",.07)=RDT
+11 DO FILE^DIE(,"DGFDA","DIERR")
KILL DGFDA
+12 QUIT
End DoDot:1
+13 QUIT
