DGPFHLT2.m

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 ---DGPFHLT2   3443     printed  Apr 09, 2024@21:57:10                                                                                                                                                                                                    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