DGPFHLTM ;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 routine contains functions for sending Mailman messages related to PRF flag transfer requests.
;
Q
;
TREQMSG(DATA,DGPFA,TYPE) ; sends notification about PRF flag ownership transfer request
; DATA - Array of values to include in the message (see tag EN^DGPFHLT1)
; DGPFA - PRF assignment array
; TYPE - 1 = notification about received request, 2 = notification about received response
;
N DGMAX,MSGTXT,LNCNT,MGRP,RESLT,Z
S MGRP="DGPF PRF TRANSFER REQUESTS" ; PRF transfer requests mail group
S DGMAX=78 ; Max. line length
;
D ADDLINE^DGPFBGR("",0,DGMAX,.LNCNT,"MSGTXT")
D ADDLINE^DGPFBGR($$CJ^XLFSTR("* * * * PRF OWNERSHIP TRANSFER REQUEST NOTIFICATION * * * *",78," "),0,DGMAX,.LNCNT,"MSGTXT")
D ADDLINE^DGPFBGR("",0,DGMAX,.LNCNT,"MSGTXT")
D ADDLINE^DGPFBGR("The following PRF ownership transfer "_$S(TYPE=1:"request",1:"response")_" has been received:",0,DGMAX,.LNCNT,"MSGTXT")
D ADDLINE^DGPFBGR("",0,DGMAX,.LNCNT,"MSGTXT")
I TYPE=1 D ADDLINE^DGPFBGR($$LJ^XLFSTR("Requesting facility: ",22," ")_$G(DATA("SFNAME")),5,DGMAX,.LNCNT,"MSGTXT")
D ADDLINE^DGPFBGR($$LJ^XLFSTR("Requester name: ",22," ")_$G(DATA("REQBY")),5,DGMAX,.LNCNT,"MSGTXT")
D ADDLINE^DGPFBGR($$LJ^XLFSTR("Request date/time: ",22," ")_$$FMTE^XLFDT($G(DATA("REQDTM")),"1S"),5,DGMAX,.LNCNT,"MSGTXT")
D ADDLINE^DGPFBGR($$LJ^XLFSTR("Request reason: ",22," ")_$G(DATA("REQCMT")),5,DGMAX,.LNCNT,"MSGTXT")
D ADDLINE^DGPFBGR($$LJ^XLFSTR("PRF flag: ",22," ")_$P($G(DGPFA("FLAG")),U,2),5,DGMAX,.LNCNT,"MSGTXT")
D ADDLINE^DGPFBGR($$LJ^XLFSTR("Patient name: ",22," ")_$P($G(DGPFA("DFN")),U,2),5,DGMAX,.LNCNT,"MSGTXT")
I TYPE=2 D
.D ADDLINE^DGPFBGR($$LJ^XLFSTR("Reviewer name: ",22," ")_$G(DATA("REVBY")),5,DGMAX,.LNCNT,"MSGTXT")
.D ADDLINE^DGPFBGR($$LJ^XLFSTR("Review date/time: ",22," ")_$$FMTE^XLFDT($G(DATA("REVDTM")),"1S"),5,DGMAX,.LNCNT,"MSGTXT")
.D ADDLINE^DGPFBGR($$LJ^XLFSTR("Review reason: ",22," ")_$G(DATA("REVCMT")),5,DGMAX,.LNCNT,"MSGTXT")
.S Z=$G(DATA("REVRES")),RESLT=$S(Z="A":"Request approved",Z="D":"Request rejected",1:"Unknown")
.D ADDLINE^DGPFBGR($$LJ^XLFSTR("Review result: ",22," ")_RESLT,5,DGMAX,.LNCNT,"MSGTXT")
.Q
D ADDLINE^DGPFBGR($$REPEAT^XLFSTR("-",DGMAX),0,DGMAX,.LNCNT,"MSGTXT")
;
D SEND(MGRP,"PRF ownership transfer request notification","MSGTXT(")
Q
;
TERRMSG(MSGID,ERTXT) ; sends notification about an error that occurred in PRF flag ownership transfer request process
; MSGID - HL7 message Id
; ERTXT - array containing error text, ERTXT(line #) contains each line
;
N DGMAX,MSGTXT,ERLN,LNCNT,MGRP
S MGRP="DGPF HL7 TRANSMISSION ERRORS"
S DGMAX=78 ; Max. line length
;
D ADDLINE^DGPFBGR("",0,DGMAX,.LNCNT,"MSGTXT")
D ADDLINE^DGPFBGR($$CJ^XLFSTR("* * * * PRF OWNERSHIP TRANSFER REQUEST ERROR * * * *",78," "),0,DGMAX,.LNCNT,"MSGTXT")
D ADDLINE^DGPFBGR("",0,DGMAX,.LNCNT,"MSGTXT")
D ADDLINE^DGPFBGR("The following error occurred during PRF ownership transfer request:",0,DGMAX,.LNCNT,"MSGTXT")
D ADDLINE^DGPFBGR("",0,DGMAX,.LNCNT,"MSGTXT")
S ERLN="" F S ERLN=$O(ERTXT(ERLN)) Q:ERLN="" D ADDLINE^DGPFBGR($G(ERTXT(ERLN)),0,DGMAX,.LNCNT,"MSGTXT")
I $G(MSGID) D
.D ADDLINE^DGPFBGR("",0,DGMAX,.LNCNT,"MSGTXT")
.D ADDLINE^DGPFBGR("HL7 message Id: "_MSGID,5,DGMAX,.LNCNT,"MSGTXT")
.Q
;
D SEND(MGRP,"PRF ownership transfer request error","MSGTXT(")
Q
;
SEND(MGRP,SUBJ,MSGARY) ;send the MailMan message
; MGRP - mail group name
; MSGARY - name of message text array in open format
; SUBJ - Subject line
;
N DIFROM ;protect FM package
N XMDUZ ;sender
N XMSUB ;message subject
N XMTEXT ;name of message text array in open format
N XMY ;recipient array
N XMZ ;returned message number
N XMMG ;error
;
I MGRP="" Q
S XMDUZ="DGPRF,INTERFACE"
S XMSUB=$G(SUBJ)
S XMTEXT=MSGARY
S XMY("G."_MGRP)=""
D ^XMD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPFHLTM 4037 printed Sep 23, 2025@20:23:44 Page 2
DGPFHLTM ;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 routine contains functions for sending Mailman messages related to PRF flag transfer requests.
+5 ;
+6 QUIT
+7 ;
TREQMSG(DATA,DGPFA,TYPE) ; sends notification about PRF flag ownership transfer request
+1 ; DATA - Array of values to include in the message (see tag EN^DGPFHLT1)
+2 ; DGPFA - PRF assignment array
+3 ; TYPE - 1 = notification about received request, 2 = notification about received response
+4 ;
+5 NEW DGMAX,MSGTXT,LNCNT,MGRP,RESLT,Z
+6 ; PRF transfer requests mail group
SET MGRP="DGPF PRF TRANSFER REQUESTS"
+7 ; Max. line length
SET DGMAX=78
+8 ;
+9 DO ADDLINE^DGPFBGR("",0,DGMAX,.LNCNT,"MSGTXT")
+10 DO ADDLINE^DGPFBGR($$CJ^XLFSTR("* * * * PRF OWNERSHIP TRANSFER REQUEST NOTIFICATION * * * *",78," "),0,DGMAX,.LNCNT,"MSGTXT")
+11 DO ADDLINE^DGPFBGR("",0,DGMAX,.LNCNT,"MSGTXT")
+12 DO ADDLINE^DGPFBGR("The following PRF ownership transfer "_$SELECT(TYPE=1:"request",1:"response")_" has been received:",0,DGMAX,.LNCNT,"MSGTXT")
+13 DO ADDLINE^DGPFBGR("",0,DGMAX,.LNCNT,"MSGTXT")
+14 IF TYPE=1
DO ADDLINE^DGPFBGR($$LJ^XLFSTR("Requesting facility: ",22," ")_$GET(DATA("SFNAME")),5,DGMAX,.LNCNT,"MSGTXT")
+15 DO ADDLINE^DGPFBGR($$LJ^XLFSTR("Requester name: ",22," ")_$GET(DATA("REQBY")),5,DGMAX,.LNCNT,"MSGTXT")
+16 DO ADDLINE^DGPFBGR($$LJ^XLFSTR("Request date/time: ",22," ")_$$FMTE^XLFDT($GET(DATA("REQDTM")),"1S"),5,DGMAX,.LNCNT,"MSGTXT")
+17 DO ADDLINE^DGPFBGR($$LJ^XLFSTR("Request reason: ",22," ")_$GET(DATA("REQCMT")),5,DGMAX,.LNCNT,"MSGTXT")
+18 DO ADDLINE^DGPFBGR($$LJ^XLFSTR("PRF flag: ",22," ")_$PIECE($GET(DGPFA("FLAG")),U,2),5,DGMAX,.LNCNT,"MSGTXT")
+19 DO ADDLINE^DGPFBGR($$LJ^XLFSTR("Patient name: ",22," ")_$PIECE($GET(DGPFA("DFN")),U,2),5,DGMAX,.LNCNT,"MSGTXT")
+20 IF TYPE=2
Begin DoDot:1
+21 DO ADDLINE^DGPFBGR($$LJ^XLFSTR("Reviewer name: ",22," ")_$GET(DATA("REVBY")),5,DGMAX,.LNCNT,"MSGTXT")
+22 DO ADDLINE^DGPFBGR($$LJ^XLFSTR("Review date/time: ",22," ")_$$FMTE^XLFDT($GET(DATA("REVDTM")),"1S"),5,DGMAX,.LNCNT,"MSGTXT")
+23 DO ADDLINE^DGPFBGR($$LJ^XLFSTR("Review reason: ",22," ")_$GET(DATA("REVCMT")),5,DGMAX,.LNCNT,"MSGTXT")
+24 SET Z=$GET(DATA("REVRES"))
SET RESLT=$SELECT(Z="A":"Request approved",Z="D":"Request rejected",1:"Unknown")
+25 DO ADDLINE^DGPFBGR($$LJ^XLFSTR("Review result: ",22," ")_RESLT,5,DGMAX,.LNCNT,"MSGTXT")
+26 QUIT
End DoDot:1
+27 DO ADDLINE^DGPFBGR($$REPEAT^XLFSTR("-",DGMAX),0,DGMAX,.LNCNT,"MSGTXT")
+28 ;
+29 DO SEND(MGRP,"PRF ownership transfer request notification","MSGTXT(")
+30 QUIT
+31 ;
TERRMSG(MSGID,ERTXT) ; sends notification about an error that occurred in PRF flag ownership transfer request process
+1 ; MSGID - HL7 message Id
+2 ; ERTXT - array containing error text, ERTXT(line #) contains each line
+3 ;
+4 NEW DGMAX,MSGTXT,ERLN,LNCNT,MGRP
+5 SET MGRP="DGPF HL7 TRANSMISSION ERRORS"
+6 ; Max. line length
SET DGMAX=78
+7 ;
+8 DO ADDLINE^DGPFBGR("",0,DGMAX,.LNCNT,"MSGTXT")
+9 DO ADDLINE^DGPFBGR($$CJ^XLFSTR("* * * * PRF OWNERSHIP TRANSFER REQUEST ERROR * * * *",78," "),0,DGMAX,.LNCNT,"MSGTXT")
+10 DO ADDLINE^DGPFBGR("",0,DGMAX,.LNCNT,"MSGTXT")
+11 DO ADDLINE^DGPFBGR("The following error occurred during PRF ownership transfer request:",0,DGMAX,.LNCNT,"MSGTXT")
+12 DO ADDLINE^DGPFBGR("",0,DGMAX,.LNCNT,"MSGTXT")
+13 SET ERLN=""
FOR
SET ERLN=$ORDER(ERTXT(ERLN))
if ERLN=""
QUIT
DO ADDLINE^DGPFBGR($GET(ERTXT(ERLN)),0,DGMAX,.LNCNT,"MSGTXT")
+14 IF $GET(MSGID)
Begin DoDot:1
+15 DO ADDLINE^DGPFBGR("",0,DGMAX,.LNCNT,"MSGTXT")
+16 DO ADDLINE^DGPFBGR("HL7 message Id: "_MSGID,5,DGMAX,.LNCNT,"MSGTXT")
+17 QUIT
End DoDot:1
+18 ;
+19 DO SEND(MGRP,"PRF ownership transfer request error","MSGTXT(")
+20 QUIT
+21 ;
SEND(MGRP,SUBJ,MSGARY) ;send the MailMan message
+1 ; MGRP - mail group name
+2 ; MSGARY - name of message text array in open format
+3 ; SUBJ - Subject line
+4 ;
+5 ;protect FM package
NEW DIFROM
+6 ;sender
NEW XMDUZ
+7 ;message subject
NEW XMSUB
+8 ;name of message text array in open format
NEW XMTEXT
+9 ;recipient array
NEW XMY
+10 ;returned message number
NEW XMZ
+11 ;error
NEW XMMG
+12 ;
+13 IF MGRP=""
QUIT
+14 SET XMDUZ="DGPRF,INTERFACE"
+15 SET XMSUB=$GET(SUBJ)
+16 SET XMTEXT=MSGARY
+17 SET XMY("G."_MGRP)=""
+18 DO ^XMD
+19 QUIT
