DGPFHLU5 ;ALB/RPM - PRF HL7 ACK PROCESSING ; 6/21/06 10:18am
;;5.3;Registration;**425,718,650**;Aug 13, 1993;Build 3
;
Q
;
PROCERR(DGLIEN,DGACK,DGERR) ;process errors returned from ACK
;
; Input:
; DGLIEN - IEN of PRF HL7 TRANSMISSION LOG (#26.17) file
; DGACK - array of ACK parse data
; DGERR - array of parsed errors (ex: DGERR(1)=error_code)
;
; Output: none
;
N DGPFA ;assignment array
N DGPFAH ;assignment history array
N DGPFL ;HL7 transmission log array
N DGXMTXT ;mailman msg text array
;
I +$G(DGLIEN),$D(DGACK),$D(DGERR) D
. ;
. ;retrieve the HL7 transmission log values
. Q:'$$GETLOG^DGPFHLL(DGLIEN,.DGPFL)
. ;
. ;retrieve assignment history values
. Q:'$$GETHIST^DGPFAAH(+$G(DGPFL("ASGNHIST")),.DGPFAH)
. ;
. ;retransmit and quit if dialog error code "Assignment not found"
. I $$FNDDIA(261102,.DGERR) D Q
. . ;transmit all assignment records to rejecting site
. . Q:'$$XMIT^DGPFLMT5(+$G(DGPFAH("ASSIGN")),$P($G(DGPFL("SITE")),U))
. . ;update HL7 transmission log status (RE-TRANSMITTED)
. . D STOSTAT^DGPFHLL(26.17,DGLIEN,"RT")
. ;
. ;retrieve assignment values
. Q:'$$GETASGN^DGPFAA(+$G(DGPFAH("ASSIGN")),.DGPFA)
. ;
. S DGXMTXT=$NA(^TMP("DGPFERR",$J))
. K @DGXMTXT
. ;
. ;create message text array
. D BLDMSG(.DGPFA,.DGACK,.DGERR,DGXMTXT)
. ;
. ;send the notification message
. D SEND(DGXMTXT)
. ;
. ;cleanup
. K @DGXMTXT
Q
;
BLDMSG(DGPFA,DGACK,DGERR,DGXMTXT) ;build MailMan message array
;
; Supported DBIA #2171: The supported DBIA is uses to access Kernel
; APIs for retrieving Station numbers and names
; from the INSTITUTION (#4) file.
; Supported DBIA #2701: The supported DBIA is used to access MPI APIs
; for retrieving an ICN for a given DFN.
;
; Input:
; DGPFA - assignment data array
; DGACK - array of ACK data
; DGERR - array of parsed errors (ex: DGERR(1)=error_code)
;
; Output:
; DGXMTXT - array of MailMan text lines
;
N DGCNT ;error count
N DGCOD ;error code
N DGDEM ;patient demographics array
N DGDFN ;pointer to PATIENT (#2) file
N DGDLG ;DIALOG array
N DGFAC ;facility data array from XUAF4 call
N DGI ;generic counter
N DGICN ;integrated control number
N DGLIN ;line counter
N DGMAX ;maximum line length
N DGSITE ;results of VASITE call
N DGSNDSTA ;sending station number
N DGSNDNAM ;sending station name
N DGTBL ;error code table array
;
S DGDFN=+$G(DGPFA("DFN"))
Q:(DGDFN'>0)
;
;retrieve patient demographics
Q:'$$GETPAT^DGPFUT2(DGDFN,.DGDEM)
S DGICN=$$GETICN^MPIF001(DGDFN)
S DGICN=$S(+DGICN>0:DGICN,1:$P(DGICN,U,2))
;
;load error code table
D BLDVA086^DGPFHLU3(.DGTBL)
;
S DGLIN=0
S DGMAX=65
S DGSITE=$$SITE^VASITE()
S DGSNDSTA=$G(DGACK("SNDFAC"))
D F4^XUAF4(DGSNDSTA,.DGFAC,"","")
S DGSNDNAM=$S(DGFAC>0:$G(DGFAC("NAME")),1:"")
;
D ADDLINE("",0,DGMAX,.DGLIN,DGXMTXT)
D ADDLINE("* * * * P R F H L 7 E R R O R E N C O U N T E R E D * * * *",0,DGMAX,.DGLIN,DGXMTXT)
D ADDLINE("",0,DGMAX,.DGLIN,DGXMTXT)
D ADDLINE("A facility could not process the following Patient Record Flag assignment on "_$$FMTE^XLFDT($G(DGACK("MSGDTM")))_".",0,DGMAX,.DGLIN,DGXMTXT)
D ADDLINE("",0,DGMAX,.DGLIN,DGXMTXT)
D ADDLINE("Message Control ID#: "_$G(DGACK("MSGID")),4,DGMAX,.DGLIN,DGXMTXT)
D ADDLINE("Receiving Facility name: "_DGSNDNAM_" ("_DGSNDSTA_")",0,DGMAX,.DGLIN,DGXMTXT)
D ADDLINE("",0,DGMAX,.DGLIN,DGXMTXT)
D ADDLINE("Flag Name: "_$P($G(DGPFA("FLAG")),U,2),14,DGMAX,.DGLIN,DGXMTXT)
D ADDLINE("",0,DGMAX,.DGLIN,DGXMTXT)
D ADDLINE("Patient Name: "_DGDEM("NAME"),11,DGMAX,.DGLIN,DGXMTXT)
D ADDLINE("Social Security #: "_DGDEM("SSN"),6,DGMAX,.DGLIN,DGXMTXT)
D ADDLINE("Date of Birth: "_$$FMTE^XLFDT(DGDEM("DOB"),"2D"),10,DGMAX,.DGLIN,DGXMTXT)
D ADDLINE("Integrated Control #: "_DGICN,3,DGMAX,.DGLIN,DGXMTXT)
D ADDLINE("Owning Site: "_$P($G(DGPFA("OWNER")),U,2)_" ("_$$STA^XUAF4($P($G(DGPFA("OWNER")),U))_")",12,DGMAX,.DGLIN,DGXMTXT)
D ADDLINE("",0,DGMAX,.DGLIN,DGXMTXT)
;
;loop through each error
S DGCNT=0
F S DGCNT=$O(DGERR(DGCNT)) Q:'DGCNT D
. K DGDLG
. S DGCOD=DGERR(DGCNT)
. ;
. ;assume numeric error code is a DIALOG
. I DGCOD?1N.N D BLD^DIALOG(DGCOD,"","","DGDLG","S")
. I $D(DGDLG) D FORMAT^DGPFLMT4(.DGDLG,DGMAX-12)
. ;
. ;if not a DIALOG, then is it a table entry?
. I '$D(DGDLG),DGCOD]"",$D(DGTBL(DGCOD,"DESC")) S DGDLG(1)=DGTBL(DGCOD,"DESC")
. ;
. ;not a DIALOG or table entry - then error is unknown
. I '$D(DGDLG) S DGDLG(1)="Unknown Error code: '"_DGCOD_"'"
. ;
. ;error header
. D ADDLINE("Reason#: "_DGCNT,0,DGMAX,.DGLIN,DGXMTXT)
. ;
. ;loop through error text array
. S DGI=0
. F S DGI=$O(DGDLG(DGI)) Q:'DGI D
. . D ADDLINE(DGDLG(DGI),12,DGMAX,.DGLIN,DGXMTXT)
. ;
. ;error separator
. D ADDLINE("",0,DGMAX,.DGLIN,DGXMTXT)
;
Q
;
ADDLINE(DGTEXT,DGINDENT,DGMAXLEN,DGCNT,DGXMTXT) ;add text line to message array
;
; Input:
; DGTEXT - text string
; DGINDENT - number of spaces to insert at start of line
; DGMAXLEN - maximum desired line length (default: 60)
; DGCNT - line number passed by reference
;
; Output:
; DGXMTXT - array of text strings
;
N DGAVAIL ;available space for text
N DGLINE ;truncated text
N DGLOC ;location of space character
N DGPAD ;space indent
;
S DGTEXT=$G(DGTEXT)
S DGINDENT=+$G(DGINDENT)
S DGMAXLEN=+$G(DGMAXLEN)
S:'DGMAXLEN DGMAXLEN=60
I DGINDENT>(DGMAXLEN-1) S DGINDENT=0
S DGCNT=$G(DGCNT,0) ;default to 0
;
S DGPAD=$$REPEAT^XLFSTR(" ",DGINDENT)
;
;determine available space for text
S DGAVAIL=(DGMAXLEN-DGINDENT)
F D Q:('$L(DGTEXT))
. ;
. ;find potential line break
. S DGLOC=$L($E(DGTEXT,1,DGAVAIL)," ")
. ;
. ;break a line that is too long when it has potential line breaks
. I $L(DGTEXT)>DGAVAIL,DGLOC D
. . S DGLINE=$P(DGTEXT," ",1,$S(DGLOC>1:DGLOC-1,1:1))
. . S DGTEXT=$P(DGTEXT," ",$S(DGLOC>1:DGLOC,1:DGLOC+1),$L(DGTEXT," "))
. E D
. . S DGLINE=DGTEXT,DGTEXT=""
. ;
. S DGCNT=DGCNT+1
. S @DGXMTXT@(DGCNT)=DGPAD_DGLINE
Q
;
SEND(DGXMTXT) ;send the MailMan message
;
; Input:
; DGXMTXT - name of message text array in closed format
;
; Output:
; none
;
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
;
S XMDUZ="Patient Record Flag Module"
S XMSUB="PRF MESSAGE TRANSMISSION ERROR"
S XMTEXT=$$OREF^DILF(DGXMTXT)
S XMY("G.DGPF HL7 TRANSMISSION ERRORS")=""
D ^XMD
Q
;
FNDDIA(DGDIA,DGERR) ;find dialog code
;This function searches an array for a specific DIALOG (#.84) code.
;
; Input: (required)
; DGDIA - dialog error code
; DGERR - array of parsed errors (ex: DGERR(1)=error_code)
;
; Output:
; Function value - 1 on success; 0 on failure
;
N DGI ;generic counter
N DGRSLT ;function value
S (DGI,DGRSLT)=0
;
I +$G(DGDIA),$D(DGERR) D
. F S DGI=$O(DGERR(DGI)) Q:'DGI D Q:DGRSLT
. . I $G(DGERR(DGI))=DGDIA S DGRSLT=1
;
Q DGRSLT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPFHLU5 7294 printed Sep 23, 2025@20:23:50 Page 2
DGPFHLU5 ;ALB/RPM - PRF HL7 ACK PROCESSING ; 6/21/06 10:18am
+1 ;;5.3;Registration;**425,718,650**;Aug 13, 1993;Build 3
+2 ;
+3 QUIT
+4 ;
PROCERR(DGLIEN,DGACK,DGERR) ;process errors returned from ACK
+1 ;
+2 ; Input:
+3 ; DGLIEN - IEN of PRF HL7 TRANSMISSION LOG (#26.17) file
+4 ; DGACK - array of ACK parse data
+5 ; DGERR - array of parsed errors (ex: DGERR(1)=error_code)
+6 ;
+7 ; Output: none
+8 ;
+9 ;assignment array
NEW DGPFA
+10 ;assignment history array
NEW DGPFAH
+11 ;HL7 transmission log array
NEW DGPFL
+12 ;mailman msg text array
NEW DGXMTXT
+13 ;
+14 IF +$GET(DGLIEN)
IF $DATA(DGACK)
IF $DATA(DGERR)
Begin DoDot:1
+15 ;
+16 ;retrieve the HL7 transmission log values
+17 if '$$GETLOG^DGPFHLL(DGLIEN,.DGPFL)
QUIT
+18 ;
+19 ;retrieve assignment history values
+20 if '$$GETHIST^DGPFAAH(+$GET(DGPFL("ASGNHIST")),.DGPFAH)
QUIT
+21 ;
+22 ;retransmit and quit if dialog error code "Assignment not found"
+23 IF $$FNDDIA(261102,.DGERR)
Begin DoDot:2
+24 ;transmit all assignment records to rejecting site
+25 if '$$XMIT^DGPFLMT5(+$GET(DGPFAH("ASSIGN")),$PIECE($GET(DGPFL("SITE")),U))
QUIT
+26 ;update HL7 transmission log status (RE-TRANSMITTED)
+27 DO STOSTAT^DGPFHLL(26.17,DGLIEN,"RT")
End DoDot:2
QUIT
+28 ;
+29 ;retrieve assignment values
+30 if '$$GETASGN^DGPFAA(+$GET(DGPFAH("ASSIGN")),.DGPFA)
QUIT
+31 ;
+32 SET DGXMTXT=$NAME(^TMP("DGPFERR",$JOB))
+33 KILL @DGXMTXT
+34 ;
+35 ;create message text array
+36 DO BLDMSG(.DGPFA,.DGACK,.DGERR,DGXMTXT)
+37 ;
+38 ;send the notification message
+39 DO SEND(DGXMTXT)
+40 ;
+41 ;cleanup
+42 KILL @DGXMTXT
End DoDot:1
+43 QUIT
+44 ;
BLDMSG(DGPFA,DGACK,DGERR,DGXMTXT) ;build MailMan message array
+1 ;
+2 ; Supported DBIA #2171: The supported DBIA is uses to access Kernel
+3 ; APIs for retrieving Station numbers and names
+4 ; from the INSTITUTION (#4) file.
+5 ; Supported DBIA #2701: The supported DBIA is used to access MPI APIs
+6 ; for retrieving an ICN for a given DFN.
+7 ;
+8 ; Input:
+9 ; DGPFA - assignment data array
+10 ; DGACK - array of ACK data
+11 ; DGERR - array of parsed errors (ex: DGERR(1)=error_code)
+12 ;
+13 ; Output:
+14 ; DGXMTXT - array of MailMan text lines
+15 ;
+16 ;error count
NEW DGCNT
+17 ;error code
NEW DGCOD
+18 ;patient demographics array
NEW DGDEM
+19 ;pointer to PATIENT (#2) file
NEW DGDFN
+20 ;DIALOG array
NEW DGDLG
+21 ;facility data array from XUAF4 call
NEW DGFAC
+22 ;generic counter
NEW DGI
+23 ;integrated control number
NEW DGICN
+24 ;line counter
NEW DGLIN
+25 ;maximum line length
NEW DGMAX
+26 ;results of VASITE call
NEW DGSITE
+27 ;sending station number
NEW DGSNDSTA
+28 ;sending station name
NEW DGSNDNAM
+29 ;error code table array
NEW DGTBL
+30 ;
+31 SET DGDFN=+$GET(DGPFA("DFN"))
+32 if (DGDFN'>0)
QUIT
+33 ;
+34 ;retrieve patient demographics
+35 if '$$GETPAT^DGPFUT2(DGDFN,.DGDEM)
QUIT
+36 SET DGICN=$$GETICN^MPIF001(DGDFN)
+37 SET DGICN=$SELECT(+DGICN>0:DGICN,1:$PIECE(DGICN,U,2))
+38 ;
+39 ;load error code table
+40 DO BLDVA086^DGPFHLU3(.DGTBL)
+41 ;
+42 SET DGLIN=0
+43 SET DGMAX=65
+44 SET DGSITE=$$SITE^VASITE()
+45 SET DGSNDSTA=$GET(DGACK("SNDFAC"))
+46 DO F4^XUAF4(DGSNDSTA,.DGFAC,"","")
+47 SET DGSNDNAM=$SELECT(DGFAC>0:$GET(DGFAC("NAME")),1:"")
+48 ;
+49 DO ADDLINE("",0,DGMAX,.DGLIN,DGXMTXT)
+50 DO ADDLINE("* * * * P R F H L 7 E R R O R E N C O U N T E R E D * * * *",0,DGMAX,.DGLIN,DGXMTXT)
+51 DO ADDLINE("",0,DGMAX,.DGLIN,DGXMTXT)
+52 DO ADDLINE("A facility could not process the following Patient Record Flag assignment on "_$$FMTE^XLFDT($GET(DGACK("MSGDTM")))_".",0,DGMAX,.DGLIN,DGXMTXT)
+53 DO ADDLINE("",0,DGMAX,.DGLIN,DGXMTXT)
+54 DO ADDLINE("Message Control ID#: "_$GET(DGACK("MSGID")),4,DGMAX,.DGLIN,DGXMTXT)
+55 DO ADDLINE("Receiving Facility name: "_DGSNDNAM_" ("_DGSNDSTA_")",0,DGMAX,.DGLIN,DGXMTXT)
+56 DO ADDLINE("",0,DGMAX,.DGLIN,DGXMTXT)
+57 DO ADDLINE("Flag Name: "_$PIECE($GET(DGPFA("FLAG")),U,2),14,DGMAX,.DGLIN,DGXMTXT)
+58 DO ADDLINE("",0,DGMAX,.DGLIN,DGXMTXT)
+59 DO ADDLINE("Patient Name: "_DGDEM("NAME"),11,DGMAX,.DGLIN,DGXMTXT)
+60 DO ADDLINE("Social Security #: "_DGDEM("SSN"),6,DGMAX,.DGLIN,DGXMTXT)
+61 DO ADDLINE("Date of Birth: "_$$FMTE^XLFDT(DGDEM("DOB"),"2D"),10,DGMAX,.DGLIN,DGXMTXT)
+62 DO ADDLINE("Integrated Control #: "_DGICN,3,DGMAX,.DGLIN,DGXMTXT)
+63 DO ADDLINE("Owning Site: "_$PIECE($GET(DGPFA("OWNER")),U,2)_" ("_$$STA^XUAF4($PIECE($GET(DGPFA("OWNER")),U))_")",12,DGMAX,.DGLIN,DGXMTXT)
+64 DO ADDLINE("",0,DGMAX,.DGLIN,DGXMTXT)
+65 ;
+66 ;loop through each error
+67 SET DGCNT=0
+68 FOR
SET DGCNT=$ORDER(DGERR(DGCNT))
if 'DGCNT
QUIT
Begin DoDot:1
+69 KILL DGDLG
+70 SET DGCOD=DGERR(DGCNT)
+71 ;
+72 ;assume numeric error code is a DIALOG
+73 IF DGCOD?1N.N
DO BLD^DIALOG(DGCOD,"","","DGDLG","S")
+74 IF $DATA(DGDLG)
DO FORMAT^DGPFLMT4(.DGDLG,DGMAX-12)
+75 ;
+76 ;if not a DIALOG, then is it a table entry?
+77 IF '$DATA(DGDLG)
IF DGCOD]""
IF $DATA(DGTBL(DGCOD,"DESC"))
SET DGDLG(1)=DGTBL(DGCOD,"DESC")
+78 ;
+79 ;not a DIALOG or table entry - then error is unknown
+80 IF '$DATA(DGDLG)
SET DGDLG(1)="Unknown Error code: '"_DGCOD_"'"
+81 ;
+82 ;error header
+83 DO ADDLINE("Reason#: "_DGCNT,0,DGMAX,.DGLIN,DGXMTXT)
+84 ;
+85 ;loop through error text array
+86 SET DGI=0
+87 FOR
SET DGI=$ORDER(DGDLG(DGI))
if 'DGI
QUIT
Begin DoDot:2
+88 DO ADDLINE(DGDLG(DGI),12,DGMAX,.DGLIN,DGXMTXT)
End DoDot:2
+89 ;
+90 ;error separator
+91 DO ADDLINE("",0,DGMAX,.DGLIN,DGXMTXT)
End DoDot:1
+92 ;
+93 QUIT
+94 ;
ADDLINE(DGTEXT,DGINDENT,DGMAXLEN,DGCNT,DGXMTXT) ;add text line to message array
+1 ;
+2 ; Input:
+3 ; DGTEXT - text string
+4 ; DGINDENT - number of spaces to insert at start of line
+5 ; DGMAXLEN - maximum desired line length (default: 60)
+6 ; DGCNT - line number passed by reference
+7 ;
+8 ; Output:
+9 ; DGXMTXT - array of text strings
+10 ;
+11 ;available space for text
NEW DGAVAIL
+12 ;truncated text
NEW DGLINE
+13 ;location of space character
NEW DGLOC
+14 ;space indent
NEW DGPAD
+15 ;
+16 SET DGTEXT=$GET(DGTEXT)
+17 SET DGINDENT=+$GET(DGINDENT)
+18 SET DGMAXLEN=+$GET(DGMAXLEN)
+19 if 'DGMAXLEN
SET DGMAXLEN=60
+20 IF DGINDENT>(DGMAXLEN-1)
SET DGINDENT=0
+21 ;default to 0
SET DGCNT=$GET(DGCNT,0)
+22 ;
+23 SET DGPAD=$$REPEAT^XLFSTR(" ",DGINDENT)
+24 ;
+25 ;determine available space for text
+26 SET DGAVAIL=(DGMAXLEN-DGINDENT)
+27 FOR
Begin DoDot:1
+28 ;
+29 ;find potential line break
+30 SET DGLOC=$LENGTH($EXTRACT(DGTEXT,1,DGAVAIL)," ")
+31 ;
+32 ;break a line that is too long when it has potential line breaks
+33 IF $LENGTH(DGTEXT)>DGAVAIL
IF DGLOC
Begin DoDot:2
+34 SET DGLINE=$PIECE(DGTEXT," ",1,$SELECT(DGLOC>1:DGLOC-1,1:1))
+35 SET DGTEXT=$PIECE(DGTEXT," ",$SELECT(DGLOC>1:DGLOC,1:DGLOC+1),$LENGTH(DGTEXT," "))
End DoDot:2
+36 IF '$TEST
Begin DoDot:2
+37 SET DGLINE=DGTEXT
SET DGTEXT=""
End DoDot:2
+38 ;
+39 SET DGCNT=DGCNT+1
+40 SET @DGXMTXT@(DGCNT)=DGPAD_DGLINE
End DoDot:1
if ('$LENGTH(DGTEXT))
QUIT
+41 QUIT
+42 ;
SEND(DGXMTXT) ;send the MailMan message
+1 ;
+2 ; Input:
+3 ; DGXMTXT - name of message text array in closed format
+4 ;
+5 ; Output:
+6 ; none
+7 ;
+8 ;protect FM package
NEW DIFROM
+9 ;sender
NEW XMDUZ
+10 ;message subject
NEW XMSUB
+11 ;name of message text array in open format
NEW XMTEXT
+12 ;recipient array
NEW XMY
+13 ;returned message number
NEW XMZ
+14 ;
+15 SET XMDUZ="Patient Record Flag Module"
+16 SET XMSUB="PRF MESSAGE TRANSMISSION ERROR"
+17 SET XMTEXT=$$OREF^DILF(DGXMTXT)
+18 SET XMY("G.DGPF HL7 TRANSMISSION ERRORS")=""
+19 DO ^XMD
+20 QUIT
+21 ;
FNDDIA(DGDIA,DGERR) ;find dialog code
+1 ;This function searches an array for a specific DIALOG (#.84) code.
+2 ;
+3 ; Input: (required)
+4 ; DGDIA - dialog error code
+5 ; DGERR - array of parsed errors (ex: DGERR(1)=error_code)
+6 ;
+7 ; Output:
+8 ; Function value - 1 on success; 0 on failure
+9 ;
+10 ;generic counter
NEW DGI
+11 ;function value
NEW DGRSLT
+12 SET (DGI,DGRSLT)=0
+13 ;
+14 IF +$GET(DGDIA)
IF $DATA(DGERR)
Begin DoDot:1
+15 FOR
SET DGI=$ORDER(DGERR(DGI))
if 'DGI
QUIT
Begin DoDot:2
+16 IF $GET(DGERR(DGI))=DGDIA
SET DGRSLT=1
End DoDot:2
if DGRSLT
QUIT
End DoDot:1
+17 ;
+18 QUIT DGRSLT
