- 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 Jan 18, 2025@03:48:30 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