- DGPFHLR ;ALB/RPM - PRF HL7 RECEIVE DRIVERS ; Sep 11, 2023@10:20:27
- ;;5.3;Registration;**425,650,951,1005,1091**;Aug 13, 1993;Build 28
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- ; Reference to SAVEHL7^EHMHL7 supported by ICR #7424
- ;
- RCV ;Receive all message types and route to message specific receiver
- ;
- ;This procedure is the main driver entry point for receiving all
- ;message types (ORU, ACK, QRY and ORF) for patient record flag
- ;assignment sharing.
- ;
- ;All procedures and functions assume that all VistA HL7 environment
- ;variables are properly initialized and will produce a fatal error if
- ;they are missing.
- ;
- ;The received message is copied to a temporary work global for
- ;processing. The message type is determined from the MSH segment and
- ;a receive processing procedure specific to the message type is called.
- ;(Ex. ORU~R01 message calls procedure: RCVORU). The specific receive
- ;processing procedure calls a message specific parse procedure to
- ;validate the message data and return data arrays for storage. If no
- ;parse errors are reported during validation, then the data arrays are
- ;stored by the receive processing procedure. Control, along with any
- ;parse validation errors, is then passed to the message specific send
- ;processing procedures to build and transmit the acknowledgment and
- ;query results messages.
- ;
- ; The message specific procedures are as follows:
- ;
- ; Message Receive Procedure Parse Procedure Send Procedure
- ; ------- ----------------- ---------------- --------------
- ; ORU~R01 RCVORU^DGPFHLR PARSORU^DGPFHLU SNDACK^DGPFHLS
- ; ACK~R01 RCVACK^DGPFHLR PARSACK^DGPFHLU4 N/A
- ; QRY~R02 RCVQRY^DGPFHLR PARSQRY^DGPFHLQ3 SNDORF^DGPFHLS
- ; ORF~R04 RCVORF^DGPFHLR PARSORF^DGPFHLQ3 N/A
- ;
- N DGCNT
- N DGMSGTYP
- N DGSEG
- N DGSEGCNT
- N DGWRK
- ;
- S DGWRK=$NA(^TMP("DGPFHL7",$J))
- K @DGWRK
- ;
- ;load work global with segments
- F DGSEGCNT=1:1 X HLNEXT Q:HLQUIT'>0 D
- . S DGCNT=0
- . S @DGWRK@(DGSEGCNT,DGCNT)=HLNODE
- . F S DGCNT=$O(HLNODE(DGCNT)) Q:'DGCNT D
- . . S @DGWRK@(DGSEGCNT,DGCNT)=HLNODE(DGCNT)
- ;
- ;get message type from "MSH"
- I $$NXTSEG^DGPFHLUT(DGWRK,0,HL("FS"),.DGSEG),$G(DGSEG("TYPE"))="MSH" D
- . S DGMSGTYP=$P(DGSEG(9),$E(HL("ECH"),1),1)
- . ;HLMTIENS is only required by RCVORU and RCVQRY, thus $GET
- . I DGMSGTYP=HL("MTN") D @("RCV"_DGMSGTYP_"(DGWRK,$G(HLMTIENS),.HL)")
- ;
- ;cleanup
- K @DGWRK
- Q
- ;
- RCVORU(DGWRK,DGMIEN,DGHL) ;Receive ORU Message Types (ORU~R01)
- ;
- ; Input:
- ; DGWRK - name of work global containing segments
- ; DGMIEN - IEN of message entry in file #773
- ; DGHL - HL environment array
- ;
- ; Output:
- ; none
- ;
- N DGORU
- N DGSEGERR ;segment error array
- N DGSTOERR ;store error array
- N DGACKTYP
- ;
- S DGORU=$NA(^TMP("DGPF",$J))
- K @DGORU
- D PARSORU^DGPFHLU(DGWRK,.DGHL,DGORU,.DGSEGERR)
- I $D(DGSEGERR) D SDORUERR(DGMIEN,.DGSEGERR,.DGSTOERR,"P") ;parse error
- ;
- I '$D(DGSEGERR),$$STOORU(DGORU,.DGSTOERR) D
- . S DGACKTYP="AA"
- E D
- . S DGACKTYP="AE"
- ;
- I $D(DGSTOERR) D SDORUERR(DGMIEN,.DGSEGERR,.DGSTOERR,"S") ;store error
- D SNDACK^DGPFHLS(DGACKTYP,DGMIEN,.DGHL,.DGSEGERR,.DGSTOERR)
- ;
- ; Save message to EHRM HL7 Message file (#1609) if received from Cerner. p1091
- ;
- I $G(HL("SAF"))="200CRNR" D ;
- . N RTNVALUE K ^TMP("EHMHL7",$J) M ^TMP("EHMHL7",$J)=@DGWRK ;
- . S RTNVALUE=$$SAVEHL7X^EHMHL7("EHMHL7","PRF","200CRNR","VISTA-"_$$STA^XUAF4($$KSP^XUPARAM("INST")),DGHL("FS"),$E(DGHL("ECH"),1),$E(DGHL("ECH"),2)) ;
- . K ^TMP("EHMHL7",$J) ;
- ;
- ;cleanup
- K @DGORU
- Q
- ;
- STOORU(DGORU,DGERR) ;store ORU data array
- ;
- ; Input:
- ; DGORU - parsed ORU segment data array
- ;
- ; Output:
- ; Function value - 1 on success; 0 on failure
- ; DGERR - defined on failure
- ;
- N DGADT ;assignment date
- N DGCNT ;count of assignment histories sent
- N DGPFA ;assignment data array
- N DGPFAH ;assignment history data array
- N DGSINGLE ;flag to indicate a single history update
- N CURASGN,DBRSCNT,DBRSNUM,LASTDT,RES,STOFLG
- ;
- ;
- S DGPFA("SNDFAC")=$G(@DGORU@("SNDFAC"))
- S DGPFA("DFN")=$G(@DGORU@("DFN"))
- S DGPFA("FLAG")=$G(@DGORU@("FLAG"))
- ;
- ;init STATUS as a placeholder, $$STATUS^DGPFUT sets value in loop
- S DGPFA("STATUS")=""
- S DGPFA("OWNER")=$G(@DGORU@("OWNER"))
- S DGPFA("ORIGSITE")=$G(@DGORU@("ORIGSITE"))
- M DGPFA("NARR")=@DGORU@("NARR")
- ; DBRS data
- S DBRSCNT=0,DBRSNUM="" F S DBRSNUM=$O(@DGORU@("DBRS",DBRSNUM)) Q:DBRSNUM="" D
- .S DBRSCNT=DBRSCNT+1
- .S DGPFA("DBRS#",DBRSCNT)=DBRSNUM
- .S DGPFA("DBRS OTHER",DBRSCNT)=$G(@DGORU@("DBRS",DBRSNUM,"OTHER"))
- .S DGPFA("DBRS DATE",DBRSCNT)=$G(@DGORU@("DBRS",DBRSNUM,"DATE"))
- .S DGPFA("DBRS ACTION",DBRSCNT)=$G(@DGORU@("DBRS",DBRSNUM,"ACTION"))
- .S DGPFA("DBRS SITE",DBRSCNT)=$G(@DGORU@("DBRS",DBRSNUM,"SITE"))
- .Q
- ;count number of assignment histories sent
- S (DGADT,DGCNT)=0
- F S DGADT=$O(@DGORU@(DGADT)) Q:'DGADT S DGCNT=DGCNT+1
- S DGSINGLE=$S(DGCNT>1:0,1:1)
- S DGADT=0
- S LASTDT=+$O(@DGORU@(9999999.999999),-1) ; date of last history record
- ;
- ;process only the last history action when assignment already exists
- S CURASGN=$$FNDASGN^DGPFAA(DGPFA("DFN"),DGPFA("FLAG"))
- I 'DGSINGLE,CURASGN S DGADT=LASTDT,DGSINGLE=1
- ;
- F S DGADT=$O(@DGORU@(DGADT)) Q:'DGADT D Q:$D(DGERR)
- .N DGPFAH ;assignment history data array
- .;
- .S DGPFAH("ASSIGNDT")=DGADT
- .S DGPFAH("ACTION")=$G(@DGORU@(DGADT,"ACTION"))
- .S DGPFAH("ENTERBY")=.5 ;POSTMASTER
- .S DGPFAH("APPRVBY")=.5 ;POSTMASTER
- .M DGPFAH("COMMENT")=@DGORU@(DGADT,"COMMENT")
- .S DGPFAH("ORIGFAC")=$G(@DGORU@(DGADT,"ORIGFAC"))
- .; DBRS data
- .S DBRSCNT=0,DBRSNUM="" F S DBRSNUM=$O(@DGORU@("DBRS",DBRSNUM)) Q:DBRSNUM="" D
- ..S DBRSCNT=DBRSCNT+1
- ..S DGPFAH("DBRS",DBRSCNT)=DBRSNUM_U_$G(@DGORU@("DBRS",DBRSNUM,"OTHER"))_U_$G(@DGORU@("DBRS",DBRSNUM,"DATE"))
- ..I $G(@DGORU@("DBRS",DBRSNUM,"ACTION"))="U" D
- ...S RES=$$FIND1^DIC(26.131,","_CURASGN_",","X",DBRSNUM)
- ...S DGPFAH("DBRS",DBRSCNT)=DGPFAH("DBRS",DBRSCNT)_U_$S(RES:"E",1:"A")
- ...Q
- ..I $G(@DGORU@("DBRS",DBRSNUM,"ACTION"))="D" S DGPFAH("DBRS",DBRSCNT)=DGPFAH("DBRS",DBRSCNT)_U_"D"
- ..S DGPFAH("DBRS",DBRSCNT)=DGPFAH("DBRS",DBRSCNT)_U_$G(@DGORU@("DBRS",DBRSNUM,"SITE"))
- ..Q
- .; calculate the assignment STATUS from the ACTION
- .S DGPFA("STATUS")=$$STATUS^DGPFUT(DGPFAH("ACTION"))
- .; calculate new review date if this is ownership transfer
- .; if action = "continue" and current owner on file is different from owner in HL7 message, then it's an ownership transfer
- .I DGPFAH("ACTION")=2,$$GET1^DIQ(26.13,CURASGN_",",.04,"I")'=DGPFA("OWNER") D
- ..; if local site or division is the new owner, set review date
- ..I DGPFA("OWNER")=$P($$SITE^VASITE(),U)!$$ISDIV^DGPFUT(DGPFA("OWNER")) D
- ...S DGPFA("REVIEWDT")=$$GETRDT^DGPFAA3($P(DGPFA("FLAG"),U),DGPFAH("ASSIGNDT"))
- ...Q
- ..Q
- .; find out if we want to overwrite existing DBRS data
- .S STOFLG="" I DGADT=LASTDT,"^2^4^5^7^8^"[(U_DGPFAH("ACTION")_U) S STOFLG="D"
- .;validate before filing for single updates and new assignments
- .I DGSINGLE!(DGPFAH("ACTION")=1) S RES=$$STOHL7^DGPFAA3(.DGPFA,.DGPFAH,"DGERR",STOFLG) Q
- .;otherwise, just file it
- .S RES=$$STOALL^DGPFAA(.DGPFA,.DGPFAH,.DGERR,STOFLG)
- .Q
- ;convert dialog to dialog code
- I $D(DGERR) S DGERR=$G(DGERR("DIERR",1))
- ;
- Q '$D(DGERR)
- ;
- RCVACK(DGWRK,DGMIEN,DGHL) ;Receive ACK Message Types (ACK~R01)
- ;
- ; Input:
- ; DGWRK - name of work global containing segments
- ; DGMIEN - IEN of message entry in file #773
- ; DGHL - HL environment array
- ;
- ; Output:
- ; none
- ;
- N DGACK ;ACK data array
- N DGERR ;error array
- N DGLIEN ;HL7 transmission log IEN
- ;
- D PARSACK^DGPFHLU4(DGWRK,.DGHL,.DGACK,.DGERR)
- S DGLIEN=$$FNDLOG^DGPFHLL(26.17,$G(DGACK("MSGID")))
- Q:'DGLIEN
- ;
- I $G(DGACK("ACKCODE"))="AA" D
- . D STOSTAT^DGPFHLL(26.17,DGLIEN,"A",.DGERR)
- E D
- . ;update transmission log status (REJECTED) and process error
- . D STOSTAT^DGPFHLL(26.17,DGLIEN,"RJ",.DGERR)
- . D PROCERR^DGPFHLU5(DGLIEN,.DGACK,.DGERR)
- Q
- ;
- RCVQRY(DGWRK,DGMIEN,DGHL) ;Receive QRY Message Types (QRY~R02)
- ;
- ; Input:
- ; DGWRK - name of work global containing segments
- ; DGMIEN - IEN of message entry in file #773
- ; DGHL - HL environment array
- ;
- ; Output:
- ; none
- ;
- N DGDFN
- N DGDFNERR
- N DGQRY
- N DGQRYERR
- N DGSEGERR
- ;
- D PARSQRY^DGPFHLQ3(DGWRK,.DGHL,.DGQRY,.DGSEGERR)
- S DGDFN=$$GETDFN^DGPFUT2(DGQRY("ICN"),"DGDFNERR")
- I DGDFN'>0,$G(DGDFNERR("DIERR",1))]"" D
- . S DGQRYERR=DGDFNERR("DIERR",1)
- D SNDORF^DGPFHLS(.DGQRY,DGMIEN,.DGHL,DGDFN,.DGSEGERR,.DGQRYERR)
- Q
- ;
- RCVORF(DGWRK,DGMIEN,DGHL) ;Receive ORF Message Types (ORF~R04)
- ;
- ; Input:
- ; DGWRK - name of work global containing segments
- ; DGMIEN - IEN of message entry in file #773
- ; DGHL - HL environment array
- ;
- ; Output:
- ; none
- ;
- N DGDFN ;pointer to PATIENT (#2) file
- N DGLIEN ;HL7 query log IEN
- N DGORF ;ORF data array root
- N DGERR ;parser error array
- N DGSTAT ;query log status
- ;
- S DGORF=$NA(^TMP("DGPF",$J))
- K @DGORF
- D PARSORF^DGPFHLQ4(DGWRK,.DGHL,DGORF,.DGERR)
- S DGDFN=+$$GETDFN^MPIF001($G(@DGORF@("ICN")))
- ;
- ;successful query
- I $G(@DGORF@("ACKCODE"))="AA" D
- . S DGSTAT=$S(+$O(@DGORF@(0))>0:"A",1:"AN")
- . ;
- . ;REJECT when filer fails; otherwise mark event as COMPLETE
- . I '$$STOORF(DGDFN,DGORF) D
- . . S DGSTAT="RJ"
- . . S DGERR($O(DGERR(""),-1)+1)=261120 ;Unable to file
- . E D STOEVNT^DGPFHLL1(DGDFN,"C")
- ;
- ;failed query
- I $G(@DGORF@("ACKCODE"))'="AA" S DGSTAT="RJ"
- ;
- ;find and update query log status
- S DGLIEN=$$FNDLOG^DGPFHLL(26.19,$G(@DGORF@("MSGID")))
- I DGLIEN D STOSTAT^DGPFHLL(26.19,DGLIEN,DGSTAT,.DGERR)
- ;
- ;purge PRF HL7 QUERY LOG when status is COMPLETE
- I $$GETSTAT^DGPFHLL1(DGDFN)="C" D PRGQLOG^DGPFHLL($$FNDEVNT^DGPFHLL1(DGDFN))
- ;
- ;cleanup
- K @DGORF
- Q
- ;
- STOORF(DGDFN,DGORF,DGERR) ;store ORF data
- ;
- ; Input:
- ; DGDFN - pointer to patient in PATIENT (#2) file
- ; DGORF - parsed ORF segments data array
- ;
- ; Output:
- ; Function value - 1 on success; 0 on failure
- ; DGERR - defined on failure
- ;
- N DGADT ;activity date ("ASSIGNDT")
- N DGPFA ;assignment data array
- N DGPFAH ;assignment history data array
- N DGSET ;set id to represent a single PRF assignment
- N CURASGN,DBRSCNT,DBRSNUM,RES
- ;
- S DGSET=0 F S DGSET=$O(@DGORF@(DGSET)) Q:'DGSET D
- .N DGPFA ;assignment data array
- .;
- .S DGPFA("DFN")=DGDFN
- .S DGPFA("FLAG")=$G(@DGORF@(DGSET,"FLAG"))
- .Q:DGPFA("FLAG")']""
- .;prevent overwriting existing assignments
- .S CURASGN=$$FNDASGN^DGPFAA(DGPFA("DFN"),DGPFA("FLAG")) Q:CURASGN
- .;init STATUS as a placeholder, $$STATUS^DGPFUT sets value in loop
- .S DGPFA("STATUS")=""
- .S DGPFA("OWNER")=$G(@DGORF@(DGSET,"OWNER"))
- .S DGPFA("ORIGSITE")=$G(@DGORF@(DGSET,"ORIGSITE"))
- .M DGPFA("NARR")=@DGORF@(DGSET,"NARR")
- .; DBRS data
- .S DBRSCNT=0,DBRSNUM="" F S DBRSNUM=$O(@DGORF@(DGSET,"DBRS",DBRSNUM)) Q:DBRSNUM="" D
- ..S DBRSCNT=DBRSCNT+1
- ..S DGPFA("DBRS#",DBRSCNT)=DBRSNUM
- ..S DGPFA("DBRS OTHER",DBRSCNT)=$G(@DGORF@(DGSET,"DBRS",DBRSNUM,"OTHER"))
- ..S DGPFA("DBRS DATE",DBRSCNT)=$G(@DGORF@(DGSET,"DBRS",DBRSNUM,"DATE"))
- ..S DGPFA("DBRS ACTION",DBRSCNT)=$G(@DGORF@(DGSET,"DBRS",DBRSNUM,"ACTION"))
- ..S DGPFA("DBRS SITE",DBRSCNT)=$G(@DGORF@(DGSET,"DBRS",DBRSNUM,"SITE"))
- ..Q
- .S DGADT=0 ;each DGADT represents a single PRF history action
- .F S DGADT=$O(@DGORF@(DGSET,DGADT)) Q:'DGADT D Q:$D(DGERR)
- ..N DGPFAH ;assignment history data array
- ..;
- ..S DGPFAH("ASSIGNDT")=DGADT
- ..S DGPFAH("ACTION")=$G(@DGORF@(DGSET,DGADT,"ACTION"))
- ..S DGPFAH("ENTERBY")=.5 ;POSTMASTER
- ..S DGPFAH("APPRVBY")=.5 ;POSTMASTER
- ..M DGPFAH("COMMENT")=@DGORF@(DGSET,DGADT,"COMMENT")
- ..S DGPFAH("ORIGFAC")=$G(@DGORF@(DGSET,DGADT,"ORIGFAC"))
- ..; DBRS data
- ..S DBRSCNT=0,DBRSNUM="" F S DBRSNUM=$O(@DGORF@(DGSET,"DBRS",DBRSNUM)) Q:DBRSNUM="" D
- ...S DBRSCNT=DBRSCNT+1
- ...S DGPFAH("DBRS",DBRSCNT)=DBRSNUM_U_$G(@DGORF@(DGSET,"DBRS",DBRSNUM,"OTHER"))
- ...S DGPFAH("DBRS",DBRSCNT)=DGPFAH("DBRS",DBRSCNT)_U_$G(@DGORF@(DGSET,"DBRS",DBRSNUM,"DATE"))
- ...I $G(@DGORF@(DGSET,"DBRS",DBRSNUM,"ACTION"))="D" S DGPFAH("DBRS",DBRSCNT)=DGPFAH("DBRS",DBRSCNT)_U_"D" Q
- ...S DGPFAH("DBRS",DBRSCNT)=DGPFAH("DBRS",DBRSCNT)_U_"A"
- ...S DGPFAH("DBRS",DBRSCNT)=DGPFAH("DBRS",DBRSCNT)_U_$G(@DGORF@(DGSET,"DBRS",DBRSNUM,"SITE"))
- ...Q
- ..;calculate the assignment STATUS from the ACTION
- ..S DGPFA("STATUS")=$$STATUS^DGPFUT(DGPFAH("ACTION"))
- ..S RES=$$STOALL^DGPFAA(.DGPFA,.DGPFAH,.DGERR,"")
- ..Q
- .Q
- Q '$D(DGERR)
- ;
- ;call to $$PROD^XUPROD supported by ICR #4440
- ;
- SDORUERR(DGMIEN,DGSEGERR,DGSTOERR,DGETYP) ;
- N XMDUZ,XMSUB,XMTEXT,XMY,XMZ ;MailMan variables
- N DGTXT,DGSTAT,DGCODE
- 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.DG PRF APPLICATION ERRORS")=""
- I DGETYP="P" D
- .D ERRMSGP(DGMIEN,.DGSEGERR,.DGTXT)
- I DGETYP="S" D
- .S DGTXT(1)="A store error occurred."
- .S DGCODE=$G(DGSTOERR("DIERR",1))
- .S:$L(DGCODE)>0 DGTXT(2)="The error code is "_DGCODE_"."
- S XMTEXT="DGTXT("
- D ^XMD
- Q
- ;
- ERRMSGP(DGMIEN,DGERR,DGTXT) ;
- N DGLC,DGSEG,DGFLD,DGE,DGI,DGJ,DGK,DGEMSG
- S DGLC=1
- S DGTXT(DGLC)="One or more parse errors occurred in message #"_DGMIEN_"."
- S DGI="" F S DGI=$O(DGERR(DGI)) Q:DGI="" D
- .S DGSEG=DGI ;segment name
- .S DGJ="" F S DGJ=$O(DGERR(DGI,DGJ)) Q:DGJ="" D
- ..S DGK="" F S DGK=$O(DGERR(DGI,DGJ,DGK)) Q:DGK="" D
- ...S DGFLD=DGK
- ...S DGE=$G(DGERR(DGI,DGJ,DGK))
- ...S DGEMSG="Error #"_DGE_" occurred in "_DGSEG_"-"_DGFLD
- ...S DGLC=DGLC+1,DGTXT(DGLC)=DGEMSG_"."
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPFHLR 13861 printed Jan 18, 2025@03:48:25 Page 2
- DGPFHLR ;ALB/RPM - PRF HL7 RECEIVE DRIVERS ; Sep 11, 2023@10:20:27
- +1 ;;5.3;Registration;**425,650,951,1005,1091**;Aug 13, 1993;Build 28
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- +4 ; Reference to SAVEHL7^EHMHL7 supported by ICR #7424
- +5 ;
- RCV ;Receive all message types and route to message specific receiver
- +1 ;
- +2 ;This procedure is the main driver entry point for receiving all
- +3 ;message types (ORU, ACK, QRY and ORF) for patient record flag
- +4 ;assignment sharing.
- +5 ;
- +6 ;All procedures and functions assume that all VistA HL7 environment
- +7 ;variables are properly initialized and will produce a fatal error if
- +8 ;they are missing.
- +9 ;
- +10 ;The received message is copied to a temporary work global for
- +11 ;processing. The message type is determined from the MSH segment and
- +12 ;a receive processing procedure specific to the message type is called.
- +13 ;(Ex. ORU~R01 message calls procedure: RCVORU). The specific receive
- +14 ;processing procedure calls a message specific parse procedure to
- +15 ;validate the message data and return data arrays for storage. If no
- +16 ;parse errors are reported during validation, then the data arrays are
- +17 ;stored by the receive processing procedure. Control, along with any
- +18 ;parse validation errors, is then passed to the message specific send
- +19 ;processing procedures to build and transmit the acknowledgment and
- +20 ;query results messages.
- +21 ;
- +22 ; The message specific procedures are as follows:
- +23 ;
- +24 ; Message Receive Procedure Parse Procedure Send Procedure
- +25 ; ------- ----------------- ---------------- --------------
- +26 ; ORU~R01 RCVORU^DGPFHLR PARSORU^DGPFHLU SNDACK^DGPFHLS
- +27 ; ACK~R01 RCVACK^DGPFHLR PARSACK^DGPFHLU4 N/A
- +28 ; QRY~R02 RCVQRY^DGPFHLR PARSQRY^DGPFHLQ3 SNDORF^DGPFHLS
- +29 ; ORF~R04 RCVORF^DGPFHLR PARSORF^DGPFHLQ3 N/A
- +30 ;
- +31 NEW DGCNT
- +32 NEW DGMSGTYP
- +33 NEW DGSEG
- +34 NEW DGSEGCNT
- +35 NEW DGWRK
- +36 ;
- +37 SET DGWRK=$NAME(^TMP("DGPFHL7",$JOB))
- +38 KILL @DGWRK
- +39 ;
- +40 ;load work global with segments
- +41 FOR DGSEGCNT=1:1
- XECUTE HLNEXT
- if HLQUIT'>0
- QUIT
- Begin DoDot:1
- +42 SET DGCNT=0
- +43 SET @DGWRK@(DGSEGCNT,DGCNT)=HLNODE
- +44 FOR
- SET DGCNT=$ORDER(HLNODE(DGCNT))
- if 'DGCNT
- QUIT
- Begin DoDot:2
- +45 SET @DGWRK@(DGSEGCNT,DGCNT)=HLNODE(DGCNT)
- End DoDot:2
- End DoDot:1
- +46 ;
- +47 ;get message type from "MSH"
- +48 IF $$NXTSEG^DGPFHLUT(DGWRK,0,HL("FS"),.DGSEG)
- IF $GET(DGSEG("TYPE"))="MSH"
- Begin DoDot:1
- +49 SET DGMSGTYP=$PIECE(DGSEG(9),$EXTRACT(HL("ECH"),1),1)
- +50 ;HLMTIENS is only required by RCVORU and RCVQRY, thus $GET
- +51 IF DGMSGTYP=HL("MTN")
- DO @("RCV"_DGMSGTYP_"(DGWRK,$G(HLMTIENS),.HL)")
- End DoDot:1
- +52 ;
- +53 ;cleanup
- +54 KILL @DGWRK
- +55 QUIT
- +56 ;
- RCVORU(DGWRK,DGMIEN,DGHL) ;Receive ORU Message Types (ORU~R01)
- +1 ;
- +2 ; Input:
- +3 ; DGWRK - name of work global containing segments
- +4 ; DGMIEN - IEN of message entry in file #773
- +5 ; DGHL - HL environment array
- +6 ;
- +7 ; Output:
- +8 ; none
- +9 ;
- +10 NEW DGORU
- +11 ;segment error array
- NEW DGSEGERR
- +12 ;store error array
- NEW DGSTOERR
- +13 NEW DGACKTYP
- +14 ;
- +15 SET DGORU=$NAME(^TMP("DGPF",$JOB))
- +16 KILL @DGORU
- +17 DO PARSORU^DGPFHLU(DGWRK,.DGHL,DGORU,.DGSEGERR)
- +18 ;parse error
- IF $DATA(DGSEGERR)
- DO SDORUERR(DGMIEN,.DGSEGERR,.DGSTOERR,"P")
- +19 ;
- +20 IF '$DATA(DGSEGERR)
- IF $$STOORU(DGORU,.DGSTOERR)
- Begin DoDot:1
- +21 SET DGACKTYP="AA"
- End DoDot:1
- +22 IF '$TEST
- Begin DoDot:1
- +23 SET DGACKTYP="AE"
- End DoDot:1
- +24 ;
- +25 ;store error
- IF $DATA(DGSTOERR)
- DO SDORUERR(DGMIEN,.DGSEGERR,.DGSTOERR,"S")
- +26 DO SNDACK^DGPFHLS(DGACKTYP,DGMIEN,.DGHL,.DGSEGERR,.DGSTOERR)
- +27 ;
- +28 ; Save message to EHRM HL7 Message file (#1609) if received from Cerner. p1091
- +29 ;
- +30 ;
- IF $GET(HL("SAF"))="200CRNR"
- Begin DoDot:1
- +31 ;
- NEW RTNVALUE
- KILL ^TMP("EHMHL7",$JOB)
- MERGE ^TMP("EHMHL7",$JOB)=@DGWRK
- +32 ;
- SET RTNVALUE=$$SAVEHL7X^EHMHL7("EHMHL7","PRF","200CRNR","VISTA-"_$$STA^XUAF4($$KSP^XUPARAM("INST")),DGHL("FS"),$EXTRACT(DGHL("ECH"),1),$EXTRACT(DGHL("ECH"),2))
- +33 ;
- KILL ^TMP("EHMHL7",$JOB)
- End DoDot:1
- +34 ;
- +35 ;cleanup
- +36 KILL @DGORU
- +37 QUIT
- +38 ;
- STOORU(DGORU,DGERR) ;store ORU data array
- +1 ;
- +2 ; Input:
- +3 ; DGORU - parsed ORU segment data array
- +4 ;
- +5 ; Output:
- +6 ; Function value - 1 on success; 0 on failure
- +7 ; DGERR - defined on failure
- +8 ;
- +9 ;assignment date
- NEW DGADT
- +10 ;count of assignment histories sent
- NEW DGCNT
- +11 ;assignment data array
- NEW DGPFA
- +12 ;assignment history data array
- NEW DGPFAH
- +13 ;flag to indicate a single history update
- NEW DGSINGLE
- +14 NEW CURASGN,DBRSCNT,DBRSNUM,LASTDT,RES,STOFLG
- +15 ;
- +16 ;
- +17 SET DGPFA("SNDFAC")=$GET(@DGORU@("SNDFAC"))
- +18 SET DGPFA("DFN")=$GET(@DGORU@("DFN"))
- +19 SET DGPFA("FLAG")=$GET(@DGORU@("FLAG"))
- +20 ;
- +21 ;init STATUS as a placeholder, $$STATUS^DGPFUT sets value in loop
- +22 SET DGPFA("STATUS")=""
- +23 SET DGPFA("OWNER")=$GET(@DGORU@("OWNER"))
- +24 SET DGPFA("ORIGSITE")=$GET(@DGORU@("ORIGSITE"))
- +25 MERGE DGPFA("NARR")=@DGORU@("NARR")
- +26 ; DBRS data
- +27 SET DBRSCNT=0
- SET DBRSNUM=""
- FOR
- SET DBRSNUM=$ORDER(@DGORU@("DBRS",DBRSNUM))
- if DBRSNUM=""
- QUIT
- Begin DoDot:1
- +28 SET DBRSCNT=DBRSCNT+1
- +29 SET DGPFA("DBRS#",DBRSCNT)=DBRSNUM
- +30 SET DGPFA("DBRS OTHER",DBRSCNT)=$GET(@DGORU@("DBRS",DBRSNUM,"OTHER"))
- +31 SET DGPFA("DBRS DATE",DBRSCNT)=$GET(@DGORU@("DBRS",DBRSNUM,"DATE"))
- +32 SET DGPFA("DBRS ACTION",DBRSCNT)=$GET(@DGORU@("DBRS",DBRSNUM,"ACTION"))
- +33 SET DGPFA("DBRS SITE",DBRSCNT)=$GET(@DGORU@("DBRS",DBRSNUM,"SITE"))
- +34 QUIT
- End DoDot:1
- +35 ;count number of assignment histories sent
- +36 SET (DGADT,DGCNT)=0
- +37 FOR
- SET DGADT=$ORDER(@DGORU@(DGADT))
- if 'DGADT
- QUIT
- SET DGCNT=DGCNT+1
- +38 SET DGSINGLE=$SELECT(DGCNT>1:0,1:1)
- +39 SET DGADT=0
- +40 ; date of last history record
- SET LASTDT=+$ORDER(@DGORU@(9999999.999999),-1)
- +41 ;
- +42 ;process only the last history action when assignment already exists
- +43 SET CURASGN=$$FNDASGN^DGPFAA(DGPFA("DFN"),DGPFA("FLAG"))
- +44 IF 'DGSINGLE
- IF CURASGN
- SET DGADT=LASTDT
- SET DGSINGLE=1
- +45 ;
- +46 FOR
- SET DGADT=$ORDER(@DGORU@(DGADT))
- if 'DGADT
- QUIT
- Begin DoDot:1
- +47 ;assignment history data array
- NEW DGPFAH
- +48 ;
- +49 SET DGPFAH("ASSIGNDT")=DGADT
- +50 SET DGPFAH("ACTION")=$GET(@DGORU@(DGADT,"ACTION"))
- +51 ;POSTMASTER
- SET DGPFAH("ENTERBY")=.5
- +52 ;POSTMASTER
- SET DGPFAH("APPRVBY")=.5
- +53 MERGE DGPFAH("COMMENT")=@DGORU@(DGADT,"COMMENT")
- +54 SET DGPFAH("ORIGFAC")=$GET(@DGORU@(DGADT,"ORIGFAC"))
- +55 ; DBRS data
- +56 SET DBRSCNT=0
- SET DBRSNUM=""
- FOR
- SET DBRSNUM=$ORDER(@DGORU@("DBRS",DBRSNUM))
- if DBRSNUM=""
- QUIT
- Begin DoDot:2
- +57 SET DBRSCNT=DBRSCNT+1
- +58 SET DGPFAH("DBRS",DBRSCNT)=DBRSNUM_U_$GET(@DGORU@("DBRS",DBRSNUM,"OTHER"))_U_$GET(@DGORU@("DBRS",DBRSNUM,"DATE"))
- +59 IF $GET(@DGORU@("DBRS",DBRSNUM,"ACTION"))="U"
- Begin DoDot:3
- +60 SET RES=$$FIND1^DIC(26.131,","_CURASGN_",","X",DBRSNUM)
- +61 SET DGPFAH("DBRS",DBRSCNT)=DGPFAH("DBRS",DBRSCNT)_U_$SELECT(RES:"E",1:"A")
- +62 QUIT
- End DoDot:3
- +63 IF $GET(@DGORU@("DBRS",DBRSNUM,"ACTION"))="D"
- SET DGPFAH("DBRS",DBRSCNT)=DGPFAH("DBRS",DBRSCNT)_U_"D"
- +64 SET DGPFAH("DBRS",DBRSCNT)=DGPFAH("DBRS",DBRSCNT)_U_$GET(@DGORU@("DBRS",DBRSNUM,"SITE"))
- +65 QUIT
- End DoDot:2
- +66 ; calculate the assignment STATUS from the ACTION
- +67 SET DGPFA("STATUS")=$$STATUS^DGPFUT(DGPFAH("ACTION"))
- +68 ; calculate new review date if this is ownership transfer
- +69 ; if action = "continue" and current owner on file is different from owner in HL7 message, then it's an ownership transfer
- +70 IF DGPFAH("ACTION")=2
- IF $$GET1^DIQ(26.13,CURASGN_",",.04,"I")'=DGPFA("OWNER")
- Begin DoDot:2
- +71 ; if local site or division is the new owner, set review date
- +72 IF DGPFA("OWNER")=$PIECE($$SITE^VASITE(),U)!$$ISDIV^DGPFUT(DGPFA("OWNER"))
- Begin DoDot:3
- +73 SET DGPFA("REVIEWDT")=$$GETRDT^DGPFAA3($PIECE(DGPFA("FLAG"),U),DGPFAH("ASSIGNDT"))
- +74 QUIT
- End DoDot:3
- +75 QUIT
- End DoDot:2
- +76 ; find out if we want to overwrite existing DBRS data
- +77 SET STOFLG=""
- IF DGADT=LASTDT
- IF "^2^4^5^7^8^"[(U_DGPFAH("ACTION")_U)
- SET STOFLG="D"
- +78 ;validate before filing for single updates and new assignments
- +79 IF DGSINGLE!(DGPFAH("ACTION")=1)
- SET RES=$$STOHL7^DGPFAA3(.DGPFA,.DGPFAH,"DGERR",STOFLG)
- QUIT
- +80 ;otherwise, just file it
- +81 SET RES=$$STOALL^DGPFAA(.DGPFA,.DGPFAH,.DGERR,STOFLG)
- +82 QUIT
- End DoDot:1
- if $DATA(DGERR)
- QUIT
- +83 ;convert dialog to dialog code
- +84 IF $DATA(DGERR)
- SET DGERR=$GET(DGERR("DIERR",1))
- +85 ;
- +86 QUIT '$DATA(DGERR)
- +87 ;
- RCVACK(DGWRK,DGMIEN,DGHL) ;Receive ACK Message Types (ACK~R01)
- +1 ;
- +2 ; Input:
- +3 ; DGWRK - name of work global containing segments
- +4 ; DGMIEN - IEN of message entry in file #773
- +5 ; DGHL - HL environment array
- +6 ;
- +7 ; Output:
- +8 ; none
- +9 ;
- +10 ;ACK data array
- NEW DGACK
- +11 ;error array
- NEW DGERR
- +12 ;HL7 transmission log IEN
- NEW DGLIEN
- +13 ;
- +14 DO PARSACK^DGPFHLU4(DGWRK,.DGHL,.DGACK,.DGERR)
- +15 SET DGLIEN=$$FNDLOG^DGPFHLL(26.17,$GET(DGACK("MSGID")))
- +16 if 'DGLIEN
- QUIT
- +17 ;
- +18 IF $GET(DGACK("ACKCODE"))="AA"
- Begin DoDot:1
- +19 DO STOSTAT^DGPFHLL(26.17,DGLIEN,"A",.DGERR)
- End DoDot:1
- +20 IF '$TEST
- Begin DoDot:1
- +21 ;update transmission log status (REJECTED) and process error
- +22 DO STOSTAT^DGPFHLL(26.17,DGLIEN,"RJ",.DGERR)
- +23 DO PROCERR^DGPFHLU5(DGLIEN,.DGACK,.DGERR)
- End DoDot:1
- +24 QUIT
- +25 ;
- RCVQRY(DGWRK,DGMIEN,DGHL) ;Receive QRY Message Types (QRY~R02)
- +1 ;
- +2 ; Input:
- +3 ; DGWRK - name of work global containing segments
- +4 ; DGMIEN - IEN of message entry in file #773
- +5 ; DGHL - HL environment array
- +6 ;
- +7 ; Output:
- +8 ; none
- +9 ;
- +10 NEW DGDFN
- +11 NEW DGDFNERR
- +12 NEW DGQRY
- +13 NEW DGQRYERR
- +14 NEW DGSEGERR
- +15 ;
- +16 DO PARSQRY^DGPFHLQ3(DGWRK,.DGHL,.DGQRY,.DGSEGERR)
- +17 SET DGDFN=$$GETDFN^DGPFUT2(DGQRY("ICN"),"DGDFNERR")
- +18 IF DGDFN'>0
- IF $GET(DGDFNERR("DIERR",1))]""
- Begin DoDot:1
- +19 SET DGQRYERR=DGDFNERR("DIERR",1)
- End DoDot:1
- +20 DO SNDORF^DGPFHLS(.DGQRY,DGMIEN,.DGHL,DGDFN,.DGSEGERR,.DGQRYERR)
- +21 QUIT
- +22 ;
- RCVORF(DGWRK,DGMIEN,DGHL) ;Receive ORF Message Types (ORF~R04)
- +1 ;
- +2 ; Input:
- +3 ; DGWRK - name of work global containing segments
- +4 ; DGMIEN - IEN of message entry in file #773
- +5 ; DGHL - HL environment array
- +6 ;
- +7 ; Output:
- +8 ; none
- +9 ;
- +10 ;pointer to PATIENT (#2) file
- NEW DGDFN
- +11 ;HL7 query log IEN
- NEW DGLIEN
- +12 ;ORF data array root
- NEW DGORF
- +13 ;parser error array
- NEW DGERR
- +14 ;query log status
- NEW DGSTAT
- +15 ;
- +16 SET DGORF=$NAME(^TMP("DGPF",$JOB))
- +17 KILL @DGORF
- +18 DO PARSORF^DGPFHLQ4(DGWRK,.DGHL,DGORF,.DGERR)
- +19 SET DGDFN=+$$GETDFN^MPIF001($GET(@DGORF@("ICN")))
- +20 ;
- +21 ;successful query
- +22 IF $GET(@DGORF@("ACKCODE"))="AA"
- Begin DoDot:1
- +23 SET DGSTAT=$SELECT(+$ORDER(@DGORF@(0))>0:"A",1:"AN")
- +24 ;
- +25 ;REJECT when filer fails; otherwise mark event as COMPLETE
- +26 IF '$$STOORF(DGDFN,DGORF)
- Begin DoDot:2
- +27 SET DGSTAT="RJ"
- +28 ;Unable to file
- SET DGERR($ORDER(DGERR(""),-1)+1)=261120
- End DoDot:2
- +29 IF '$TEST
- DO STOEVNT^DGPFHLL1(DGDFN,"C")
- End DoDot:1
- +30 ;
- +31 ;failed query
- +32 IF $GET(@DGORF@("ACKCODE"))'="AA"
- SET DGSTAT="RJ"
- +33 ;
- +34 ;find and update query log status
- +35 SET DGLIEN=$$FNDLOG^DGPFHLL(26.19,$GET(@DGORF@("MSGID")))
- +36 IF DGLIEN
- DO STOSTAT^DGPFHLL(26.19,DGLIEN,DGSTAT,.DGERR)
- +37 ;
- +38 ;purge PRF HL7 QUERY LOG when status is COMPLETE
- +39 IF $$GETSTAT^DGPFHLL1(DGDFN)="C"
- DO PRGQLOG^DGPFHLL($$FNDEVNT^DGPFHLL1(DGDFN))
- +40 ;
- +41 ;cleanup
- +42 KILL @DGORF
- +43 QUIT
- +44 ;
- STOORF(DGDFN,DGORF,DGERR) ;store ORF data
- +1 ;
- +2 ; Input:
- +3 ; DGDFN - pointer to patient in PATIENT (#2) file
- +4 ; DGORF - parsed ORF segments data array
- +5 ;
- +6 ; Output:
- +7 ; Function value - 1 on success; 0 on failure
- +8 ; DGERR - defined on failure
- +9 ;
- +10 ;activity date ("ASSIGNDT")
- NEW DGADT
- +11 ;assignment data array
- NEW DGPFA
- +12 ;assignment history data array
- NEW DGPFAH
- +13 ;set id to represent a single PRF assignment
- NEW DGSET
- +14 NEW CURASGN,DBRSCNT,DBRSNUM,RES
- +15 ;
- +16 SET DGSET=0
- FOR
- SET DGSET=$ORDER(@DGORF@(DGSET))
- if 'DGSET
- QUIT
- Begin DoDot:1
- +17 ;assignment data array
- NEW DGPFA
- +18 ;
- +19 SET DGPFA("DFN")=DGDFN
- +20 SET DGPFA("FLAG")=$GET(@DGORF@(DGSET,"FLAG"))
- +21 if DGPFA("FLAG")']""
- QUIT
- +22 ;prevent overwriting existing assignments
- +23 SET CURASGN=$$FNDASGN^DGPFAA(DGPFA("DFN"),DGPFA("FLAG"))
- if CURASGN
- QUIT
- +24 ;init STATUS as a placeholder, $$STATUS^DGPFUT sets value in loop
- +25 SET DGPFA("STATUS")=""
- +26 SET DGPFA("OWNER")=$GET(@DGORF@(DGSET,"OWNER"))
- +27 SET DGPFA("ORIGSITE")=$GET(@DGORF@(DGSET,"ORIGSITE"))
- +28 MERGE DGPFA("NARR")=@DGORF@(DGSET,"NARR")
- +29 ; DBRS data
- +30 SET DBRSCNT=0
- SET DBRSNUM=""
- FOR
- SET DBRSNUM=$ORDER(@DGORF@(DGSET,"DBRS",DBRSNUM))
- if DBRSNUM=""
- QUIT
- Begin DoDot:2
- +31 SET DBRSCNT=DBRSCNT+1
- +32 SET DGPFA("DBRS#",DBRSCNT)=DBRSNUM
- +33 SET DGPFA("DBRS OTHER",DBRSCNT)=$GET(@DGORF@(DGSET,"DBRS",DBRSNUM,"OTHER"))
- +34 SET DGPFA("DBRS DATE",DBRSCNT)=$GET(@DGORF@(DGSET,"DBRS",DBRSNUM,"DATE"))
- +35 SET DGPFA("DBRS ACTION",DBRSCNT)=$GET(@DGORF@(DGSET,"DBRS",DBRSNUM,"ACTION"))
- +36 SET DGPFA("DBRS SITE",DBRSCNT)=$GET(@DGORF@(DGSET,"DBRS",DBRSNUM,"SITE"))
- +37 QUIT
- End DoDot:2
- +38 ;each DGADT represents a single PRF history action
- SET DGADT=0
- +39 FOR
- SET DGADT=$ORDER(@DGORF@(DGSET,DGADT))
- if 'DGADT
- QUIT
- Begin DoDot:2
- +40 ;assignment history data array
- NEW DGPFAH
- +41 ;
- +42 SET DGPFAH("ASSIGNDT")=DGADT
- +43 SET DGPFAH("ACTION")=$GET(@DGORF@(DGSET,DGADT,"ACTION"))
- +44 ;POSTMASTER
- SET DGPFAH("ENTERBY")=.5
- +45 ;POSTMASTER
- SET DGPFAH("APPRVBY")=.5
- +46 MERGE DGPFAH("COMMENT")=@DGORF@(DGSET,DGADT,"COMMENT")
- +47 SET DGPFAH("ORIGFAC")=$GET(@DGORF@(DGSET,DGADT,"ORIGFAC"))
- +48 ; DBRS data
- +49 SET DBRSCNT=0
- SET DBRSNUM=""
- FOR
- SET DBRSNUM=$ORDER(@DGORF@(DGSET,"DBRS",DBRSNUM))
- if DBRSNUM=""
- QUIT
- Begin DoDot:3
- +50 SET DBRSCNT=DBRSCNT+1
- +51 SET DGPFAH("DBRS",DBRSCNT)=DBRSNUM_U_$GET(@DGORF@(DGSET,"DBRS",DBRSNUM,"OTHER"))
- +52 SET DGPFAH("DBRS",DBRSCNT)=DGPFAH("DBRS",DBRSCNT)_U_$GET(@DGORF@(DGSET,"DBRS",DBRSNUM,"DATE"))
- +53 IF $GET(@DGORF@(DGSET,"DBRS",DBRSNUM,"ACTION"))="D"
- SET DGPFAH("DBRS",DBRSCNT)=DGPFAH("DBRS",DBRSCNT)_U_"D"
- QUIT
- +54 SET DGPFAH("DBRS",DBRSCNT)=DGPFAH("DBRS",DBRSCNT)_U_"A"
- +55 SET DGPFAH("DBRS",DBRSCNT)=DGPFAH("DBRS",DBRSCNT)_U_$GET(@DGORF@(DGSET,"DBRS",DBRSNUM,"SITE"))
- +56 QUIT
- End DoDot:3
- +57 ;calculate the assignment STATUS from the ACTION
- +58 SET DGPFA("STATUS")=$$STATUS^DGPFUT(DGPFAH("ACTION"))
- +59 SET RES=$$STOALL^DGPFAA(.DGPFA,.DGPFAH,.DGERR,"")
- +60 QUIT
- End DoDot:2
- if $DATA(DGERR)
- QUIT
- +61 QUIT
- End DoDot:1
- +62 QUIT '$DATA(DGERR)
- +63 ;
- +64 ;call to $$PROD^XUPROD supported by ICR #4440
- +65 ;
- SDORUERR(DGMIEN,DGSEGERR,DGSTOERR,DGETYP) ;
- +1 ;MailMan variables
- NEW XMDUZ,XMSUB,XMTEXT,XMY,XMZ
- +2 NEW DGTXT,DGSTAT,DGCODE
- +3 SET DGSTAT=$PIECE($$SITE^VASITE,U,3)
- +4 SET XMDUZ="PRF Error Processor"
- +5 SET XMSUB="PRF Application Error (station #"_DGSTAT_")"
- +6 ;production or test?
- SET XMSUB=XMSUB_" ["_$SELECT($$PROD^XUPROD:"P",1:"T")_"]"
- +7 SET XMY("G.DG PRF APPLICATION ERRORS")=""
- +8 IF DGETYP="P"
- Begin DoDot:1
- +9 DO ERRMSGP(DGMIEN,.DGSEGERR,.DGTXT)
- End DoDot:1
- +10 IF DGETYP="S"
- Begin DoDot:1
- +11 SET DGTXT(1)="A store error occurred."
- +12 SET DGCODE=$GET(DGSTOERR("DIERR",1))
- +13 if $LENGTH(DGCODE)>0
- SET DGTXT(2)="The error code is "_DGCODE_"."
- End DoDot:1
- +14 SET XMTEXT="DGTXT("
- +15 DO ^XMD
- +16 QUIT
- +17 ;
- ERRMSGP(DGMIEN,DGERR,DGTXT) ;
- +1 NEW DGLC,DGSEG,DGFLD,DGE,DGI,DGJ,DGK,DGEMSG
- +2 SET DGLC=1
- +3 SET DGTXT(DGLC)="One or more parse errors occurred in message #"_DGMIEN_"."
- +4 SET DGI=""
- FOR
- SET DGI=$ORDER(DGERR(DGI))
- if DGI=""
- QUIT
- Begin DoDot:1
- +5 ;segment name
- SET DGSEG=DGI
- +6 SET DGJ=""
- FOR
- SET DGJ=$ORDER(DGERR(DGI,DGJ))
- if DGJ=""
- QUIT
- Begin DoDot:2
- +7 SET DGK=""
- FOR
- SET DGK=$ORDER(DGERR(DGI,DGJ,DGK))
- if DGK=""
- QUIT
- Begin DoDot:3
- +8 SET DGFLD=DGK
- +9 SET DGE=$GET(DGERR(DGI,DGJ,DGK))
- +10 SET DGEMSG="Error #"_DGE_" occurred in "_DGSEG_"-"_DGFLD
- +11 SET DGLC=DGLC+1
- SET DGTXT(DGLC)=DGEMSG_"."
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +12 QUIT