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