DGPFHLS ;ALB/RPM - PRF HL7 SEND DRIVERS ; Sep 11, 2023@13:22:21
;;5.3;Registration;**425,650,1005,1028,1037,1091**;Aug 13, 1993;Build 28
;
; Reference to SAVEHL7^EHMHL7 supported by ICR #7424
;
SNDORU(DGPFIEN,DGPFHARR,DGFAC) ;Send ORU Message Types (ORU~R01)
;This function builds and transmits a single ORU message to all sites
;in the associated patient's TREATING FACILITY LIST (#391.91) file.
;The optional input parameter DGFAC overrides selection of sites
;from the TREATING FACILITY LIST file.
;
; Supported DBIA #2990: This supported DBIA is used to access the
; Registration API to generate a list of
; treating facilities for a given patient.
; Supported by ICR #2263 This ICR permits use of $$GET^XPAR().
; Input:
; DGPFIEN - (required) IEN of assignment in PRF ASSIGNMENT (#26.13)
; file to transmit
; DGPFHARR - (optional) array of assignment history IENs from the
; PRF ASSIGNMENT HISTORY (#26.14) file to
; include in ORU.
; format: DGPFHARR(assignment_date_time)=IEN
; assignment_date_time in FM format
; [default = $$GETLAST^DGPFAAH(DGPFIEN)]
; DGFAC - (optional) array of message destination facilities
; passed by reference
; format: DGFAC(#)=station#
;
; Output:
; Function value - 1 on success, 0 on failure
;
N DGHLEID ;event protocol ID
N DGHL ;VistA HL7 environment array
N DGHLROOT ;message array location
N DGPFA ;assignment data array
N DGPFAH ;assignment history data array
N DGPFHIEN ;assignment history IEN
N DGRSLT ;function value
N DGI ;counter
N DGCRNR ;flag indicating that a converted facility was found
N DGSTAT,DGSTAT2 ;status retuned when sending message
;
S DGRSLT=0
S DGHLROOT=$NA(^TMP("PRFORU",$J))
K @DGHLROOT
;
I +$G(DGPFIEN)>0,$D(^DGPF(26.13,DGPFIEN)) D
. ;
. ;retrieve assignment record
. Q:'$$GETASGN^DGPFAA(DGPFIEN,.DGPFA)
. ;
. ;set up default history IEN array
. I '$O(DGPFHARR(0)) D
. . N DGPFAH
. . S DGPFHIEN=$$GETLAST^DGPFAAH(DGPFIEN)
. . Q:'$$GETHIST^DGPFAAH(DGPFHIEN,.DGPFAH)
. . S DGPFHARR(+$G(DGPFAH("ASSIGNDT")))=DGPFHIEN
. Q:'$O(DGPFHARR(0))
. ;
. ;retrieve treating facilities when no destination is provided
. ;I $G(DGFAC(1))'>0 D TFL^VAFCTFU1(.DGFAC,+$G(DGPFA("DFN")))
. I $G(DGFAC(1))'>0 D BLDTFL2^DGPFUT2(+$G(DGPFA("DFN")),.DGFAC)
. Q:$G(DGFAC(1))'>0
. ;
. ;initialize VistA HL7 environment
. S DGHLEID=$$INIT^DGPFHLUT("DGPF PRF ORU/R01 EVENT",.DGHL)
. Q:'DGHLEID
. ;
. ;build ORU segments array
. S DGPFHIEN=$$BLDORU^DGPFHLU(.DGPFA,.DGPFHARR,.DGHL,DGHLROOT)
. Q:'DGPFHIEN
. ;
. ;transmit and log messages
. S DGSTAT=0,DGSTAT2=0
. S DGSTAT=$$XMIT^DGPFHLU6(DGPFHIEN,DGHLEID,.DGFAC,DGHLROOT,.DGHL)
. ;
. ;Should a copy be sent to the regional HC router?
. S DGCRNR=$$CERNER2(DGPFIEN)
. D:DGCRNR
. . S DGSTAT2=$$XMIT1^DGPFHLU6(DGPFHIEN,DGHLEID,DGHLROOT,.DGHL)
. . ;
. . ; Save HL7 message to EHRM HL7 Message file (#1609) - p1091
. . ;
. . N RTNVALUE K ^TMP("EHMHL7",$J) M ^TMP("EHMHL7",$J)=@DGHLROOT ;
. . S RTNVALUE=$$SAVEHL7X^EHMHL7("EHMHL7","PRF","VISTA-"_$$STA^XUAF4($$KSP^XUPARAM("INST")),"200CRNR",DGHL("FS"),$E(DGHL("ECH"),1),$E(DGHL("ECH"),2)) ;
. . K ^TMP("EHMHL7",$J) ;
. ;
. Q:'$G(DGSTAT)
. I DGCRNR,'$G(DGSTAT2) Q
. ;success
. S DGRSLT=1
;
;cleanup
K @DGHLROOT
Q DGRSLT
;
SNDACK(DGACKTYP,DGMIEN,DGHL,DGSEGERR,DGSTOERR) ;Send ACK Message Type (ACK~R01)
;This procedure assumes the the VistA HL7 environment is providing the
;environment variables and will produce a fatal error if they are
;missing.
;
; Input:
; DGACKTYP - (required) ACK message type ("AA","AE")
; DGMIEN - (required) IEN of message entry in file #773
; DGHL - (required) HL7 environment array
; DGSEGERR - (optional) Errors found during parsing
; DGSTOERR - (optional) Errors during data storage
;
; Output:
; none
;
N DGHLROOT
N DGHLERR
;
Q:($G(DGACKTYP)']"")
Q:('+$G(DGMIEN))
;
S DGHLROOT=$NA(^TMP("HLA",$J))
K @DGHLROOT
;
;build ACK segments array
I $$BLDACK^DGPFHLU4(DGACKTYP,DGHLROOT,.DGHL,.DGSEGERR,.DGSTOERR) D
. ;send MailMan message on AE or AR
. D SNDMAIL(DGMIEN,.DGHL,$NA(^TMP("HLA",$J)))
. ;generate the message
. D GENACK^HLMA1(DGHL("EID"),DGMIEN,DGHL("EIDS"),"GM",1,.DGHLERR)
;
;cleanup
K @DGHLROOT
Q
;
SNDQRY(DGDFN,DGMODE,DGFAC) ;Send QRY Message Types (QRY~R02)
;This function transmits a PRF Query (QRY~R02) HL7 message to a given
;patient's treating facility.
;
; Input:
; DGDFN - (required) pointer to patient in PATIENT (#2) file
; DGMODE - (optional) type of HL7 connection to use ("1" - direct
; connection, "2" - deferred connection [default],
; "3" - direct connection/display mode)
; DGFAC - (optional) station number of query destination.
; [default - most recent unqueried treating facility]
;
; Output:
; Function value - 1 on success, 0 on failure
;
N DGEVNT
N DGHLROOT
N DGHLLNK
N DGHL
N DGICN
N DGLSQ
N DGMSG
N DGMSGID
N DGNXTF
N DGRSLT
N HLL
N DGHLEID
N DGHLRSLT
N DGHLP
;
;the following HL* variables are created by DIRECT^HLMA
N HL,HLCS,HLDOM,HLECH,HLFS,HLINST,HLINSTN
N HLMTIEN,HLNEXT,HLNODE,HLPARAM,HLPROD,HLQ
N HLQUIT
;
S DGMODE=+$G(DGMODE)
S DGFAC=$G(DGFAC)
S DGRSLT=0
S DGHLROOT=$NA(^TMP("HLS",$J))
K @DGHLROOT
;
I +$G(DGDFN)>0,$D(^DPT(DGDFN,0)) D
. ;
. ;ICN must be national
. Q:'$$MPIOK^DGPFUT(DGDFN,.DGICN)
. ;
. ;find event, get last site queried and next treating facility
. S DGEVNT=$$FNDEVNT^DGPFHLL1(DGDFN)
. I 'DGEVNT,DGMODE'=3 D ;no event and not display? create it!
. . D STOEVNT^DGPFHLL1(DGDFN)
. . S DGEVNT=$$FNDEVNT^DGPFHLL1(DGDFN)
. S DGLSQ=$$GETLSQ^DGPFHLL(DGEVNT)
. S DGNXTF=$$GETNXTF^DGPFUT(DGDFN,DGLSQ)
. ;
. ;determine treating facility institution number to query
. S DGFAC=$S(DGFAC]"":$$IEN^XUAF4(DGFAC),DGNXTF:DGNXTF,DGLSQ&('DGNXTF):$$GETNXTF^DGPFUT(DGDFN),1:0)
. ;
. ;mark query event COMPLETE and return SUCCESS when no non-local
. ;treating facilities are found and no previous queries have been run.
. I DGFAC'>0,'DGLSQ D
. . D STOEVNT^DGPFHLL1(DGDFN,"C")
. . S DGRSLT=1
. Q:(DGFAC'>0)
. ;
. ;retrieve treating facility HL Logical Link and build HLL array
. S DGHLLNK=$$GETLINK^DGPFHLUT(DGFAC)
. Q:(DGHLLNK=0)
. S HLL("LINKS",1)="DGPF PRF ORF/R04 SUBSC"_U_DGHLLNK
. ;S:$$CERNER(DGDFN) HLL("LINKS",1)="DGPF PRF ORF/R04 SUBSC"_U_"VACRNR"
. ;
. ;initialize VistA HL7 environment
. S DGHLEID=$$INIT^DGPFHLUT("DGPF PRF QRY/R02 EVENT",.DGHL)
. Q:'DGHLEID
. ;
. ;build QRY segments array
. Q:'$$BLDQRY^DGPFHLQ(DGDFN,DGICN,DGHLROOT,.DGHL)
. ;
. ;display busy message to interactive users when direct-connect
. I DGMODE=1!(DGMODE=3),$E($G(IOST),1,2)="C-" D
. . S DGMSG(1)="Attempting to connect to "_$P($$NS^XUAF4(DGFAC),U)
. . S DGMSG(2)="to search for Patient Record Flag Assignments."
. . S DGMSG(3)="This request may take some time, please be patient ..."
. . D EN^DDIOL(.DGMSG)
. ;
. ;generate HL7 message
. I DGMODE=1!(DGMODE=3) D ;generate direct-connect HL7 message
. . S $P(DGHLP("SUBSCRIBER"),U,5)=$$STA^XUAF4(DGFAC)
. . D DIRECT^HLMA(DGHLEID,"GM",1,.DGHLRSLT,"",.DGHLP)
. . ;The DIRECT^HLMA API contains a bug that causes the message ID
. . ;returned to be based on the HL7 MESSAGE TEXT (#772) file IEN and
. . ;not the HL7 MESSAGE ADMINISTRATION (#773) file IEN. Therefore,
. . ;the following call to $$CONVMID is required to convert the
. . ;message ID to the value stored in file #773.
. . S DGMSGID=$$CONVMID^DGPFHLUT($P(DGHLRSLT,U))
. . I DGMODE=1,DGMSGID>0 D STOQXMIT^DGPFHLL(DGEVNT,DGMSGID,DGFAC)
. . I HLMTIEN,DGMODE'=3 D RCV^DGPFHLR
. . I DGMODE=3 D DISPLAY^DGPFHLUQ(HLMTIEN,DGHLRSLT)
. . ;success
. . I '+$P(DGHLRSLT,U,2) S DGRSLT=1
. ;
. E D ;generate deferred HL7 message
. . S $P(DGHLP("SUBSCRIBER"),U,5)=$$STA^XUAF4(DGFAC)
. . D GENERATE^HLMA(DGHLEID,"GM",1,.DGHLRSLT,"",.DGHLP)
. . I $P(DGHLRSLT,U)>0 D STOQXMIT^DGPFHLL(DGEVNT,$P(DGHLRSLT,U),DGFAC)
. . ;success
. . I '+$P(DGHLRSLT,U,2) S DGRSLT=1
;
;cleanup
K @DGHLROOT
Q DGRSLT
;
SNDORF(DGQRY,DGMIEN,DGHL,DGDFN,DGSEGERR,DGQRYERR) ;Send ORF Message Type (ORF~R04)
;This procedure assumes the the VistA HL7 environment is providing the
;environment variables and will produce a fatal error if they are
;missing.
;
; Input:
; DGQRY - (required) Array of QRY parsing results
; DGMIEN - (required) IEN of message entry in file #773
; DGHL - (required) HL7 environment array
; DGDFN - (required) Pointer to patient in PATIENT (#2) file
; DGSEGERR - (optional) Errors found during parsing
; DGQRYERR - (optional) Errors found during query
;
; Output:
; none
;
N DGHLROOT
N DGHLERR
;
Q:('$D(DGQRY))
Q:('+$G(DGMIEN))
;
S DGHLROOT=$NA(^TMP("HLA",$J))
K @DGHLROOT
;
;build ORF segments array
I $$BLDORF^DGPFHLQ(DGHLROOT,.DGHL,DGDFN,.DGQRY,.DGSEGERR,.DGQRYERR) D
. ;send MailMan message on AE or AR
. D SNDMAIL(DGMIEN,.DGHL,$NA(^TMP("HLA",$J)))
. ;generate the message
. D GENACK^HLMA1(DGHL("EID"),DGMIEN,DGHL("EIDS"),"GM",1,.DGHLERR)
;
;cleanup
K @DGHLROOT
Q
;
;patch 1005
CERNER(DGDFN) ;
;Is this a Cerner patient (i.e., is 200CRNR in the TFL)?
;input variables
;DGDFN - pointer to PATIENT (#2) file
;return value:
; 1 - yes, 0 - no
;
N DGRES,DGOUT,DGSITE,DGKEY,DGI
S DGRES=0
S DGSITE=$P($$SITE^VASITE,U,3)
S DGKEY=DGDFN_U_"PI"_U_"USVHA"_U_DGSITE
D TFL^VAFCTFU2(.DGOUT,DGKEY)
S DGI=0
F S DGI=$O(DGOUT(DGI)) Q:DGI="" D
.I $P(DGOUT(DGI),U,4)="200CRNR",$P(DGOUT(DGI),U,2)="PI" S DGRES=1
Q DGRES
;
CERNER2(DGIEN) ;
;This is a convenience routine that accepts a patient record flag
;assignment as input parameter.
;input variables:
;DGIEN - pointer to PRF ASSIGNMENT (#26.13) file
;return value:
; 1 - yes, 0 - no
;
N DGDFN,DGPFA
D GETASGN^DGPFAA(DGIEN,.DGPFA)
S DGDFN=$P(DGPFA("DFN"),U)
Q $$CERNER(DGDFN)
;
SNDMAIL(DGMIEN,DGHL,DGROOT) ;
;This entry point sends a MailMan message reporting that an AE or
;AR was generated.
;input variables:
;DGMIEN (required) - IEN of offending message in file #773
;DGHL (required) - The "HL" array
;DGROOT (required) - root for the application ack passed to GENACK^HLMA1
;
;call to $$PROD^XUPROD supported by ICR #4440
;
N XMDUZ,XMSUB,XMTEXT,XMY,XMZ ;MailMan variables
N DGTXT,DGSTAT,DGMSA,DGTYP,DGFS,DGI,DGMID
S DGFS=DGHL("FS")
S DGMSA=$G(@DGROOT@(1))
S DGTYP=$P(DGMSA,DGFS,2)
S DGMID=$P(DGMSA,DGFS,3)
Q:DGTYP="AA" ;Don't send mail messages for succesful AAs.
S DGSTAT=$P($$SITE^VASITE,U,3)
S XMDUZ="PRF Error Processor"
S XMSUB="PRF Application Error (station #"_DGSTAT_")"
S XMSUB=XMSUB_" ["_$S($$PROD^XUPROD:"P",1:"T")_"]" ;production or test?
S XMY("G.DGPF APPLICATION ERRORS")=""
S XMTEXT="DGTXT("
S DGTXT(1)="An error occurred in message #"_DGMIEN
S DGTXT(2)="Original MID: "_DGMID
S DGTXT(3)=""
S DGTXT(4)="MESSAGE TEXT (ACK):"
S DGI="" F S DGI=$O(@DGROOT@(DGI)) Q:DGI="" D
. S DGTXT(DGI+4)=$G(@DGROOT@(DGI))
D ^XMD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPFHLS 11534 printed Sep 23, 2025@20:23:39 Page 2
DGPFHLS ;ALB/RPM - PRF HL7 SEND DRIVERS ; Sep 11, 2023@13:22:21
+1 ;;5.3;Registration;**425,650,1005,1028,1037,1091**;Aug 13, 1993;Build 28
+2 ;
+3 ; Reference to SAVEHL7^EHMHL7 supported by ICR #7424
+4 ;
SNDORU(DGPFIEN,DGPFHARR,DGFAC) ;Send ORU Message Types (ORU~R01)
+1 ;This function builds and transmits a single ORU message to all sites
+2 ;in the associated patient's TREATING FACILITY LIST (#391.91) file.
+3 ;The optional input parameter DGFAC overrides selection of sites
+4 ;from the TREATING FACILITY LIST file.
+5 ;
+6 ; Supported DBIA #2990: This supported DBIA is used to access the
+7 ; Registration API to generate a list of
+8 ; treating facilities for a given patient.
+9 ; Supported by ICR #2263 This ICR permits use of $$GET^XPAR().
+10 ; Input:
+11 ; DGPFIEN - (required) IEN of assignment in PRF ASSIGNMENT (#26.13)
+12 ; file to transmit
+13 ; DGPFHARR - (optional) array of assignment history IENs from the
+14 ; PRF ASSIGNMENT HISTORY (#26.14) file to
+15 ; include in ORU.
+16 ; format: DGPFHARR(assignment_date_time)=IEN
+17 ; assignment_date_time in FM format
+18 ; [default = $$GETLAST^DGPFAAH(DGPFIEN)]
+19 ; DGFAC - (optional) array of message destination facilities
+20 ; passed by reference
+21 ; format: DGFAC(#)=station#
+22 ;
+23 ; Output:
+24 ; Function value - 1 on success, 0 on failure
+25 ;
+26 ;event protocol ID
NEW DGHLEID
+27 ;VistA HL7 environment array
NEW DGHL
+28 ;message array location
NEW DGHLROOT
+29 ;assignment data array
NEW DGPFA
+30 ;assignment history data array
NEW DGPFAH
+31 ;assignment history IEN
NEW DGPFHIEN
+32 ;function value
NEW DGRSLT
+33 ;counter
NEW DGI
+34 ;flag indicating that a converted facility was found
NEW DGCRNR
+35 ;status retuned when sending message
NEW DGSTAT,DGSTAT2
+36 ;
+37 SET DGRSLT=0
+38 SET DGHLROOT=$NAME(^TMP("PRFORU",$JOB))
+39 KILL @DGHLROOT
+40 ;
+41 IF +$GET(DGPFIEN)>0
IF $DATA(^DGPF(26.13,DGPFIEN))
Begin DoDot:1
+42 ;
+43 ;retrieve assignment record
+44 if '$$GETASGN^DGPFAA(DGPFIEN,.DGPFA)
QUIT
+45 ;
+46 ;set up default history IEN array
+47 IF '$ORDER(DGPFHARR(0))
Begin DoDot:2
+48 NEW DGPFAH
+49 SET DGPFHIEN=$$GETLAST^DGPFAAH(DGPFIEN)
+50 if '$$GETHIST^DGPFAAH(DGPFHIEN,.DGPFAH)
QUIT
+51 SET DGPFHARR(+$GET(DGPFAH("ASSIGNDT")))=DGPFHIEN
End DoDot:2
+52 if '$ORDER(DGPFHARR(0))
QUIT
+53 ;
+54 ;retrieve treating facilities when no destination is provided
+55 ;I $G(DGFAC(1))'>0 D TFL^VAFCTFU1(.DGFAC,+$G(DGPFA("DFN")))
+56 IF $GET(DGFAC(1))'>0
DO BLDTFL2^DGPFUT2(+$GET(DGPFA("DFN")),.DGFAC)
+57 if $GET(DGFAC(1))'>0
QUIT
+58 ;
+59 ;initialize VistA HL7 environment
+60 SET DGHLEID=$$INIT^DGPFHLUT("DGPF PRF ORU/R01 EVENT",.DGHL)
+61 if 'DGHLEID
QUIT
+62 ;
+63 ;build ORU segments array
+64 SET DGPFHIEN=$$BLDORU^DGPFHLU(.DGPFA,.DGPFHARR,.DGHL,DGHLROOT)
+65 if 'DGPFHIEN
QUIT
+66 ;
+67 ;transmit and log messages
+68 SET DGSTAT=0
SET DGSTAT2=0
+69 SET DGSTAT=$$XMIT^DGPFHLU6(DGPFHIEN,DGHLEID,.DGFAC,DGHLROOT,.DGHL)
+70 ;
+71 ;Should a copy be sent to the regional HC router?
+72 SET DGCRNR=$$CERNER2(DGPFIEN)
+73 if DGCRNR
Begin DoDot:2
+74 SET DGSTAT2=$$XMIT1^DGPFHLU6(DGPFHIEN,DGHLEID,DGHLROOT,.DGHL)
+75 ;
+76 ; Save HL7 message to EHRM HL7 Message file (#1609) - p1091
+77 ;
+78 ;
NEW RTNVALUE
KILL ^TMP("EHMHL7",$JOB)
MERGE ^TMP("EHMHL7",$JOB)=@DGHLROOT
+79 ;
SET RTNVALUE=$$SAVEHL7X^EHMHL7("EHMHL7","PRF","VISTA-"_$$STA^XUAF4($$KSP^XUPARAM("INST")),"200CRNR",DGHL("FS"),$EXTRACT(DGHL("ECH"),1),$EXTRACT(DGHL("ECH"),2))
+80 ;
KILL ^TMP("EHMHL7",$JOB)
End DoDot:2
+81 ;
+82 if '$GET(DGSTAT)
QUIT
+83 IF DGCRNR
IF '$GET(DGSTAT2)
QUIT
+84 ;success
+85 SET DGRSLT=1
End DoDot:1
+86 ;
+87 ;cleanup
+88 KILL @DGHLROOT
+89 QUIT DGRSLT
+90 ;
SNDACK(DGACKTYP,DGMIEN,DGHL,DGSEGERR,DGSTOERR) ;Send ACK Message Type (ACK~R01)
+1 ;This procedure assumes the the VistA HL7 environment is providing the
+2 ;environment variables and will produce a fatal error if they are
+3 ;missing.
+4 ;
+5 ; Input:
+6 ; DGACKTYP - (required) ACK message type ("AA","AE")
+7 ; DGMIEN - (required) IEN of message entry in file #773
+8 ; DGHL - (required) HL7 environment array
+9 ; DGSEGERR - (optional) Errors found during parsing
+10 ; DGSTOERR - (optional) Errors during data storage
+11 ;
+12 ; Output:
+13 ; none
+14 ;
+15 NEW DGHLROOT
+16 NEW DGHLERR
+17 ;
+18 if ($GET(DGACKTYP)']"")
QUIT
+19 if ('+$GET(DGMIEN))
QUIT
+20 ;
+21 SET DGHLROOT=$NAME(^TMP("HLA",$JOB))
+22 KILL @DGHLROOT
+23 ;
+24 ;build ACK segments array
+25 IF $$BLDACK^DGPFHLU4(DGACKTYP,DGHLROOT,.DGHL,.DGSEGERR,.DGSTOERR)
Begin DoDot:1
+26 ;send MailMan message on AE or AR
+27 DO SNDMAIL(DGMIEN,.DGHL,$NAME(^TMP("HLA",$JOB)))
+28 ;generate the message
+29 DO GENACK^HLMA1(DGHL("EID"),DGMIEN,DGHL("EIDS"),"GM",1,.DGHLERR)
End DoDot:1
+30 ;
+31 ;cleanup
+32 KILL @DGHLROOT
+33 QUIT
+34 ;
SNDQRY(DGDFN,DGMODE,DGFAC) ;Send QRY Message Types (QRY~R02)
+1 ;This function transmits a PRF Query (QRY~R02) HL7 message to a given
+2 ;patient's treating facility.
+3 ;
+4 ; Input:
+5 ; DGDFN - (required) pointer to patient in PATIENT (#2) file
+6 ; DGMODE - (optional) type of HL7 connection to use ("1" - direct
+7 ; connection, "2" - deferred connection [default],
+8 ; "3" - direct connection/display mode)
+9 ; DGFAC - (optional) station number of query destination.
+10 ; [default - most recent unqueried treating facility]
+11 ;
+12 ; Output:
+13 ; Function value - 1 on success, 0 on failure
+14 ;
+15 NEW DGEVNT
+16 NEW DGHLROOT
+17 NEW DGHLLNK
+18 NEW DGHL
+19 NEW DGICN
+20 NEW DGLSQ
+21 NEW DGMSG
+22 NEW DGMSGID
+23 NEW DGNXTF
+24 NEW DGRSLT
+25 NEW HLL
+26 NEW DGHLEID
+27 NEW DGHLRSLT
+28 NEW DGHLP
+29 ;
+30 ;the following HL* variables are created by DIRECT^HLMA
+31 NEW HL,HLCS,HLDOM,HLECH,HLFS,HLINST,HLINSTN
+32 NEW HLMTIEN,HLNEXT,HLNODE,HLPARAM,HLPROD,HLQ
+33 NEW HLQUIT
+34 ;
+35 SET DGMODE=+$GET(DGMODE)
+36 SET DGFAC=$GET(DGFAC)
+37 SET DGRSLT=0
+38 SET DGHLROOT=$NAME(^TMP("HLS",$JOB))
+39 KILL @DGHLROOT
+40 ;
+41 IF +$GET(DGDFN)>0
IF $DATA(^DPT(DGDFN,0))
Begin DoDot:1
+42 ;
+43 ;ICN must be national
+44 if '$$MPIOK^DGPFUT(DGDFN,.DGICN)
QUIT
+45 ;
+46 ;find event, get last site queried and next treating facility
+47 SET DGEVNT=$$FNDEVNT^DGPFHLL1(DGDFN)
+48 ;no event and not display? create it!
IF 'DGEVNT
IF DGMODE'=3
Begin DoDot:2
+49 DO STOEVNT^DGPFHLL1(DGDFN)
+50 SET DGEVNT=$$FNDEVNT^DGPFHLL1(DGDFN)
End DoDot:2
+51 SET DGLSQ=$$GETLSQ^DGPFHLL(DGEVNT)
+52 SET DGNXTF=$$GETNXTF^DGPFUT(DGDFN,DGLSQ)
+53 ;
+54 ;determine treating facility institution number to query
+55 SET DGFAC=$SELECT(DGFAC]"":$$IEN^XUAF4(DGFAC),DGNXTF:DGNXTF,DGLSQ&('DGNXTF):$$GETNXTF^DGPFUT(DGDFN),1:0)
+56 ;
+57 ;mark query event COMPLETE and return SUCCESS when no non-local
+58 ;treating facilities are found and no previous queries have been run.
+59 IF DGFAC'>0
IF 'DGLSQ
Begin DoDot:2
+60 DO STOEVNT^DGPFHLL1(DGDFN,"C")
+61 SET DGRSLT=1
End DoDot:2
+62 if (DGFAC'>0)
QUIT
+63 ;
+64 ;retrieve treating facility HL Logical Link and build HLL array
+65 SET DGHLLNK=$$GETLINK^DGPFHLUT(DGFAC)
+66 if (DGHLLNK=0)
QUIT
+67 SET HLL("LINKS",1)="DGPF PRF ORF/R04 SUBSC"_U_DGHLLNK
+68 ;S:$$CERNER(DGDFN) HLL("LINKS",1)="DGPF PRF ORF/R04 SUBSC"_U_"VACRNR"
+69 ;
+70 ;initialize VistA HL7 environment
+71 SET DGHLEID=$$INIT^DGPFHLUT("DGPF PRF QRY/R02 EVENT",.DGHL)
+72 if 'DGHLEID
QUIT
+73 ;
+74 ;build QRY segments array
+75 if '$$BLDQRY^DGPFHLQ(DGDFN,DGICN,DGHLROOT,.DGHL)
QUIT
+76 ;
+77 ;display busy message to interactive users when direct-connect
+78 IF DGMODE=1!(DGMODE=3)
IF $EXTRACT($GET(IOST),1,2)="C-"
Begin DoDot:2
+79 SET DGMSG(1)="Attempting to connect to "_$PIECE($$NS^XUAF4(DGFAC),U)
+80 SET DGMSG(2)="to search for Patient Record Flag Assignments."
+81 SET DGMSG(3)="This request may take some time, please be patient ..."
+82 DO EN^DDIOL(.DGMSG)
End DoDot:2
+83 ;
+84 ;generate HL7 message
+85 ;generate direct-connect HL7 message
IF DGMODE=1!(DGMODE=3)
Begin DoDot:2
+86 SET $PIECE(DGHLP("SUBSCRIBER"),U,5)=$$STA^XUAF4(DGFAC)
+87 DO DIRECT^HLMA(DGHLEID,"GM",1,.DGHLRSLT,"",.DGHLP)
+88 ;The DIRECT^HLMA API contains a bug that causes the message ID
+89 ;returned to be based on the HL7 MESSAGE TEXT (#772) file IEN and
+90 ;not the HL7 MESSAGE ADMINISTRATION (#773) file IEN. Therefore,
+91 ;the following call to $$CONVMID is required to convert the
+92 ;message ID to the value stored in file #773.
+93 SET DGMSGID=$$CONVMID^DGPFHLUT($PIECE(DGHLRSLT,U))
+94 IF DGMODE=1
IF DGMSGID>0
DO STOQXMIT^DGPFHLL(DGEVNT,DGMSGID,DGFAC)
+95 IF HLMTIEN
IF DGMODE'=3
DO RCV^DGPFHLR
+96 IF DGMODE=3
DO DISPLAY^DGPFHLUQ(HLMTIEN,DGHLRSLT)
+97 ;success
+98 IF '+$PIECE(DGHLRSLT,U,2)
SET DGRSLT=1
End DoDot:2
+99 ;
+100 ;generate deferred HL7 message
IF '$TEST
Begin DoDot:2
+101 SET $PIECE(DGHLP("SUBSCRIBER"),U,5)=$$STA^XUAF4(DGFAC)
+102 DO GENERATE^HLMA(DGHLEID,"GM",1,.DGHLRSLT,"",.DGHLP)
+103 IF $PIECE(DGHLRSLT,U)>0
DO STOQXMIT^DGPFHLL(DGEVNT,$PIECE(DGHLRSLT,U),DGFAC)
+104 ;success
+105 IF '+$PIECE(DGHLRSLT,U,2)
SET DGRSLT=1
End DoDot:2
End DoDot:1
+106 ;
+107 ;cleanup
+108 KILL @DGHLROOT
+109 QUIT DGRSLT
+110 ;
SNDORF(DGQRY,DGMIEN,DGHL,DGDFN,DGSEGERR,DGQRYERR) ;Send ORF Message Type (ORF~R04)
+1 ;This procedure assumes the the VistA HL7 environment is providing the
+2 ;environment variables and will produce a fatal error if they are
+3 ;missing.
+4 ;
+5 ; Input:
+6 ; DGQRY - (required) Array of QRY parsing results
+7 ; DGMIEN - (required) IEN of message entry in file #773
+8 ; DGHL - (required) HL7 environment array
+9 ; DGDFN - (required) Pointer to patient in PATIENT (#2) file
+10 ; DGSEGERR - (optional) Errors found during parsing
+11 ; DGQRYERR - (optional) Errors found during query
+12 ;
+13 ; Output:
+14 ; none
+15 ;
+16 NEW DGHLROOT
+17 NEW DGHLERR
+18 ;
+19 if ('$DATA(DGQRY))
QUIT
+20 if ('+$GET(DGMIEN))
QUIT
+21 ;
+22 SET DGHLROOT=$NAME(^TMP("HLA",$JOB))
+23 KILL @DGHLROOT
+24 ;
+25 ;build ORF segments array
+26 IF $$BLDORF^DGPFHLQ(DGHLROOT,.DGHL,DGDFN,.DGQRY,.DGSEGERR,.DGQRYERR)
Begin DoDot:1
+27 ;send MailMan message on AE or AR
+28 DO SNDMAIL(DGMIEN,.DGHL,$NAME(^TMP("HLA",$JOB)))
+29 ;generate the message
+30 DO GENACK^HLMA1(DGHL("EID"),DGMIEN,DGHL("EIDS"),"GM",1,.DGHLERR)
End DoDot:1
+31 ;
+32 ;cleanup
+33 KILL @DGHLROOT
+34 QUIT
+35 ;
+36 ;patch 1005
CERNER(DGDFN) ;
+1 ;Is this a Cerner patient (i.e., is 200CRNR in the TFL)?
+2 ;input variables
+3 ;DGDFN - pointer to PATIENT (#2) file
+4 ;return value:
+5 ; 1 - yes, 0 - no
+6 ;
+7 NEW DGRES,DGOUT,DGSITE,DGKEY,DGI
+8 SET DGRES=0
+9 SET DGSITE=$PIECE($$SITE^VASITE,U,3)
+10 SET DGKEY=DGDFN_U_"PI"_U_"USVHA"_U_DGSITE
+11 DO TFL^VAFCTFU2(.DGOUT,DGKEY)
+12 SET DGI=0
+13 FOR
SET DGI=$ORDER(DGOUT(DGI))
if DGI=""
QUIT
Begin DoDot:1
+14 IF $PIECE(DGOUT(DGI),U,4)="200CRNR"
IF $PIECE(DGOUT(DGI),U,2)="PI"
SET DGRES=1
End DoDot:1
+15 QUIT DGRES
+16 ;
CERNER2(DGIEN) ;
+1 ;This is a convenience routine that accepts a patient record flag
+2 ;assignment as input parameter.
+3 ;input variables:
+4 ;DGIEN - pointer to PRF ASSIGNMENT (#26.13) file
+5 ;return value:
+6 ; 1 - yes, 0 - no
+7 ;
+8 NEW DGDFN,DGPFA
+9 DO GETASGN^DGPFAA(DGIEN,.DGPFA)
+10 SET DGDFN=$PIECE(DGPFA("DFN"),U)
+11 QUIT $$CERNER(DGDFN)
+12 ;
SNDMAIL(DGMIEN,DGHL,DGROOT) ;
+1 ;This entry point sends a MailMan message reporting that an AE or
+2 ;AR was generated.
+3 ;input variables:
+4 ;DGMIEN (required) - IEN of offending message in file #773
+5 ;DGHL (required) - The "HL" array
+6 ;DGROOT (required) - root for the application ack passed to GENACK^HLMA1
+7 ;
+8 ;call to $$PROD^XUPROD supported by ICR #4440
+9 ;
+10 ;MailMan variables
NEW XMDUZ,XMSUB,XMTEXT,XMY,XMZ
+11 NEW DGTXT,DGSTAT,DGMSA,DGTYP,DGFS,DGI,DGMID
+12 SET DGFS=DGHL("FS")
+13 SET DGMSA=$GET(@DGROOT@(1))
+14 SET DGTYP=$PIECE(DGMSA,DGFS,2)
+15 SET DGMID=$PIECE(DGMSA,DGFS,3)
+16 ;Don't send mail messages for succesful AAs.
if DGTYP="AA"
QUIT
+17 SET DGSTAT=$PIECE($$SITE^VASITE,U,3)
+18 SET XMDUZ="PRF Error Processor"
+19 SET XMSUB="PRF Application Error (station #"_DGSTAT_")"
+20 ;production or test?
SET XMSUB=XMSUB_" ["_$SELECT($$PROD^XUPROD:"P",1:"T")_"]"
+21 SET XMY("G.DGPF APPLICATION ERRORS")=""
+22 SET XMTEXT="DGTXT("
+23 SET DGTXT(1)="An error occurred in message #"_DGMIEN
+24 SET DGTXT(2)="Original MID: "_DGMID
+25 SET DGTXT(3)=""
+26 SET DGTXT(4)="MESSAGE TEXT (ACK):"
+27 SET DGI=""
FOR
SET DGI=$ORDER(@DGROOT@(DGI))
if DGI=""
QUIT
Begin DoDot:1
+28 SET DGTXT(DGI+4)=$GET(@DGROOT@(DGI))
End DoDot:1
+29 DO ^XMD
+30 QUIT
