DGPFHLT2 ;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 sending RSP^K11 (response to PRF flag transfer request) messages.
;
Q
;
SEND(DGMERR,DATA) ; entry point
; DATA - Array of values to file (see tag EN^DGPFHLT1)
; DGMERR - error message to include in MSA segment
;
N DGERR,DGFDA,DGHLRSLT,ERTXT,IENS,SEGCNT
N HL,HLCMP,HLECH,HLFS,HLL,HLREP,HLSCMP
K ^TMP("HLS",$J)
; get logical link
S HLL("LINKS",1)="DGPF PRF RSP/K11 SUBSC"_U_$$GETLINK^DGPFHLUT(DATA("SENDTO"))
; Initialize the HL7
D INIT^HLFNC2("DGPF PRF RSP/K11 EVENT",.HL)
S HLFS=HL("FS"),HLECH=HL("ECH"),HLCMP=$E(HLECH),HLREP=$E(HL("ECH"),2),HLSCMP=$E(HL("ECH"),4)
; Create HL7 message
S SEGCNT=0
S SEGCNT=$$SAVESEG^DGPFHLT(SEGCNT,$$QAK()) ; QAK segment
S SEGCNT=$$SAVESEG^DGPFHLT(SEGCNT,$$QPD()) ; QPD segment
S SEGCNT=$$SAVESEG^DGPFHLT(SEGCNT,$$NTE()) ; NTE segment
; Send HL7 message
D GENERATE^HLMA("DGPF PRF RSP/K11 EVENT","GM",1,.DGHLRSLT)
I $P(DGHLRSLT,U,2)'="" D
.; There was an error while sending RSP^K11 message
.; Update log entry in file 26.22 accordingly
.S IENS=$O(^DGPF(26.22,"B",$G(DATA("REQDTM")),""))_","
.S DGFDA(26.22,IENS,.05)=5
.S DGFDA(26.22,IENS,1)=$E($P(DGHLRSLT,U,3),1,80)
.D FILE^DIE(,"DGFDA","DGERR")
.; Send Mailman notification
.S ERTXT(1)="Error while sending RSP^K11 HL7 message in response to QBP^Q11 HL7"
.S ERTXT(2)="message with message Id "_$G(DATA("MSGID"))_"."
.S ERTXT(3)="Error code: "_$P(DGHLRSLT,U,2)
.S ERTXT(4)="Error description: "_$P(DGHLRSLT,U,3)
.I $D(DGERR) D
..S ERTXT(5)=""
..S ERTXT(6)="Error while updating log entry in file 26.22."
..S ERTXT(7)="Error code: "_$G(DGERR("DIERR",1))
..S ERTXT(8)="Error description: "_$G(DGERR("DIERR",1,"TEXT",1))
..Q
.D TERRMSG^DGPFHLTM($P(DGHLRSLT,U),.ERTXT)
.Q
; update "NO RESPONSE" entries with new review date/time
D NORESPDT^DGPFHLT3($G(DATA("DFN")),$G(DATA("FLAG")),$G(DATA("REVDTM")))
K ^TMP("HLS",$J)
Q
;
QAK() ; create QAK segment
N SEG
S $P(SEG,HLFS)=$G(DATA("REQID")) ; field 1
S $P(SEG,HLFS,2)=$S($G(DATA("QOK"))=1:"OK",1:"AR") ; field 2
S $P(SEG,HLFS,3)="PRFREQ01"_HLCMP_"PRF Ownership Transfer Request" ; field 3
S SEG="QAK"_HLFS_SEG
Q SEG
;
QPD() ; create QPD segment
N IENS,SEG
S $P(SEG,HLFS)="PRFREQ01"_HLCMP_"PRF Ownership Transfer Request" ; field 1
S $P(SEG,HLFS,2)=$G(DATA("REQID")) ; field 2
S $P(SEG,HLFS,3)=$G(DATA("ICN")) ; field 3
S IENS=$G(DATA("FLAG"))_","
S $P(SEG,HLFS,4)=$$ENCHL7^DGPFHLUT($$GET1^DIQ(26.15,IENS,.01)) ; field 4
S $P(SEG,HLFS,5)=$$ENCHL7^DGPFHLUT($G(DATA("REVBY"))) ; field 5
S $P(SEG,HLFS,6)=$$HLDATE^HLFNC($G(DATA("REVDTM"))) ; field 6
S SEG="QPD"_HLFS_SEG
Q SEG
;
NTE() ; create NTE segment
N NAME,SEG,Z
S $P(SEG,HLFS)="1" ; field 1
S Z=$G(DATA("REVRES"))_HLREP_$$ENCHL7^DGPFHLUT($G(DATA("REVCMT")))
S $P(SEG,HLFS,3)=Z ; field 3
S $P(SEG,HLFS,4)="RE" ; field 4
S Z="",$P(Z,HLCMP,14)=HLSCMP_$G(DATA("ORIGOWN"))
S $P(SEG,HLFS,5)=Z ; field 5
S SEG="NTE"_HLFS_SEG
Q SEG
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPFHLT2 3443 printed Oct 16, 2024@18:48:26 Page 2
DGPFHLT2 ;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 sending RSP^K11 (response to PRF flag transfer request) messages.
+5 ;
+6 QUIT
+7 ;
SEND(DGMERR,DATA) ; entry point
+1 ; DATA - Array of values to file (see tag EN^DGPFHLT1)
+2 ; DGMERR - error message to include in MSA segment
+3 ;
+4 NEW DGERR,DGFDA,DGHLRSLT,ERTXT,IENS,SEGCNT
+5 NEW HL,HLCMP,HLECH,HLFS,HLL,HLREP,HLSCMP
+6 KILL ^TMP("HLS",$JOB)
+7 ; get logical link
+8 SET HLL("LINKS",1)="DGPF PRF RSP/K11 SUBSC"_U_$$GETLINK^DGPFHLUT(DATA("SENDTO"))
+9 ; Initialize the HL7
+10 DO INIT^HLFNC2("DGPF PRF RSP/K11 EVENT",.HL)
+11 SET HLFS=HL("FS")
SET HLECH=HL("ECH")
SET HLCMP=$EXTRACT(HLECH)
SET HLREP=$EXTRACT(HL("ECH"),2)
SET HLSCMP=$EXTRACT(HL("ECH"),4)
+12 ; Create HL7 message
+13 SET SEGCNT=0
+14 ; QAK segment
SET SEGCNT=$$SAVESEG^DGPFHLT(SEGCNT,$$QAK())
+15 ; QPD segment
SET SEGCNT=$$SAVESEG^DGPFHLT(SEGCNT,$$QPD())
+16 ; NTE segment
SET SEGCNT=$$SAVESEG^DGPFHLT(SEGCNT,$$NTE())
+17 ; Send HL7 message
+18 DO GENERATE^HLMA("DGPF PRF RSP/K11 EVENT","GM",1,.DGHLRSLT)
+19 IF $PIECE(DGHLRSLT,U,2)'=""
Begin DoDot:1
+20 ; There was an error while sending RSP^K11 message
+21 ; Update log entry in file 26.22 accordingly
+22 SET IENS=$ORDER(^DGPF(26.22,"B",$GET(DATA("REQDTM")),""))_","
+23 SET DGFDA(26.22,IENS,.05)=5
+24 SET DGFDA(26.22,IENS,1)=$EXTRACT($PIECE(DGHLRSLT,U,3),1,80)
+25 DO FILE^DIE(,"DGFDA","DGERR")
+26 ; Send Mailman notification
+27 SET ERTXT(1)="Error while sending RSP^K11 HL7 message in response to QBP^Q11 HL7"
+28 SET ERTXT(2)="message with message Id "_$GET(DATA("MSGID"))_"."
+29 SET ERTXT(3)="Error code: "_$PIECE(DGHLRSLT,U,2)
+30 SET ERTXT(4)="Error description: "_$PIECE(DGHLRSLT,U,3)
+31 IF $DATA(DGERR)
Begin DoDot:2
+32 SET ERTXT(5)=""
+33 SET ERTXT(6)="Error while updating log entry in file 26.22."
+34 SET ERTXT(7)="Error code: "_$GET(DGERR("DIERR",1))
+35 SET ERTXT(8)="Error description: "_$GET(DGERR("DIERR",1,"TEXT",1))
+36 QUIT
End DoDot:2
+37 DO TERRMSG^DGPFHLTM($PIECE(DGHLRSLT,U),.ERTXT)
+38 QUIT
End DoDot:1
+39 ; update "NO RESPONSE" entries with new review date/time
+40 DO NORESPDT^DGPFHLT3($GET(DATA("DFN")),$GET(DATA("FLAG")),$GET(DATA("REVDTM")))
+41 KILL ^TMP("HLS",$JOB)
+42 QUIT
+43 ;
QAK() ; create QAK segment
+1 NEW SEG
+2 ; field 1
SET $PIECE(SEG,HLFS)=$GET(DATA("REQID"))
+3 ; field 2
SET $PIECE(SEG,HLFS,2)=$SELECT($GET(DATA("QOK"))=1:"OK",1:"AR")
+4 ; field 3
SET $PIECE(SEG,HLFS,3)="PRFREQ01"_HLCMP_"PRF Ownership Transfer Request"
+5 SET SEG="QAK"_HLFS_SEG
+6 QUIT SEG
+7 ;
QPD() ; create QPD segment
+1 NEW IENS,SEG
+2 ; field 1
SET $PIECE(SEG,HLFS)="PRFREQ01"_HLCMP_"PRF Ownership Transfer Request"
+3 ; field 2
SET $PIECE(SEG,HLFS,2)=$GET(DATA("REQID"))
+4 ; field 3
SET $PIECE(SEG,HLFS,3)=$GET(DATA("ICN"))
+5 SET IENS=$GET(DATA("FLAG"))_","
+6 ; field 4
SET $PIECE(SEG,HLFS,4)=$$ENCHL7^DGPFHLUT($$GET1^DIQ(26.15,IENS,.01))
+7 ; field 5
SET $PIECE(SEG,HLFS,5)=$$ENCHL7^DGPFHLUT($GET(DATA("REVBY")))
+8 ; field 6
SET $PIECE(SEG,HLFS,6)=$$HLDATE^HLFNC($GET(DATA("REVDTM")))
+9 SET SEG="QPD"_HLFS_SEG
+10 QUIT SEG
+11 ;
NTE() ; create NTE segment
+1 NEW NAME,SEG,Z
+2 ; field 1
SET $PIECE(SEG,HLFS)="1"
+3 SET Z=$GET(DATA("REVRES"))_HLREP_$$ENCHL7^DGPFHLUT($GET(DATA("REVCMT")))
+4 ; field 3
SET $PIECE(SEG,HLFS,3)=Z
+5 ; field 4
SET $PIECE(SEG,HLFS,4)="RE"
+6 SET Z=""
SET $PIECE(Z,HLCMP,14)=HLSCMP_$GET(DATA("ORIGOWN"))
+7 ; field 5
SET $PIECE(SEG,HLFS,5)=Z
+8 SET SEG="NTE"_HLFS_SEG
+9 QUIT SEG
