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