DGQEHLR ;ALB/RPM - VIC REPLACEMENT HL7 RECEIVE DRIVER ; 10/6/03
;;5.3;Registration;**571,1015**;Aug 13, 1993;Build 21
;
RCV ;
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 first segment
I $$NXTSEG^DGQEHLUT(DGWRK,0,HL("FS"),.DGSEG),$G(DGSEG("TYPE"))="MSH" D
. S DGMSGTYP=$P(DGSEG(9),$E(HL("ECH"),1),1)
. I DGMSGTYP=HL("MTN") D RCVORR(DGWRK,.HL)
;
;cleanup
K @DGWRK
Q
;
RCVORR(DGWRK,DGHL) ;process a single ORR~O02 message
;
; Input:
; DGWRK - temporary segment work array
; DGHL - VistA HL7 environment array
;
; Output:
; none
;
N DGORR
N DGLIEN
N DGSTAT
;
D PARSORR(DGWRK,.DGHL,.DGORR)
;
I +$G(DGORR("MSGID")),$G(DGORR("ACKCODE"))]"" D
. S DGLIEN=$$FINDMID^DGQEHLL(DGORR("MSGID"))
. Q:'DGLIEN
. ;
. I DGORR("ACKCODE")="AA" S DGSTAT="A"
. E D
. . S DGSTAT="RJ"
. . ;send bulletin indicating failed NCMD update
. . D SENDBULL(DGLIEN,.DGORR)
. ;
. ;remove "H"old event entry from VIC HL7 TRANSMISSION LOG (#39.6) file
. D STOACK^DGQEHLL(DGLIEN,DGSTAT)
;
Q
;
PARSORR(DGWRK,DGHL,DGORR) ;Parse ORR Message/Segments
;
; Input:
; DGWRK - Closed root work global reference
; DGHL - HL7 environment array
;
; Output:
; DGORR - array of ACK results
;
N DGFS
N DGCS
N DGRS
N DGSS
N DGCURLIN
;
S DGFS=DGHL("FS")
S DGCS=$E(DGHL("ECH"),1)
S DGRS=$E(DGHL("ECH"),2)
S DGSS=$E(DGHL("ECH"),4)
S DGCURLIN=0
;
;loop through the message segments and retrieve the field data
F D Q:'DGCURLIN
. N DGSEG
. S DGCURLIN=$$NXTSEG^DGQEHLUT(DGWRK,DGCURLIN,DGFS,.DGSEG)
. Q:'DGCURLIN
. D @(DGSEG("TYPE")_"(.DGSEG,DGCS,DGRS,DGSS,.DGORR)")
Q
;
MSH(DGSEG,DGCS,DGRS,DGSS,DGORR) ;
;
; Input:
; DGSEG - MSH segment field array
; DGCS - HL7 component separator
; DGRS - HL7 repetition separator
; DGSS - HL7 sub-component separator
;
; Output:
; DGORR - array of ACK results
; "SNDFAC" - sending facility
; "RCVFAC" - receiving facility
; "MSGDTM" - message creation date/time in FileMan format
;
S DGORR("SNDFAC")=$P($G(DGSEG(4)),DGCS,1)
S DGORR("RCVFAC")=$P($G(DGSEG(6)),DGCS,1)
S DGORR("MSGDTM")=$$HL7TFM^XLFDT($G(DGSEG(7)))
Q
;
MSA(DGSEG,DGCS,DGRS,DGSS,DGORR) ;
;
; Input:
; DGSEG - MSH segment field array
; DGCS - HL7 component separator
; DGRS - HL7 repetition separator
; DGSS - HL7 sub-component separator
;
; Output:
; DGORR - array of ACK results
; "ACKCODE" - Acknowledgment code
; "MSGID" - Message Control ID of the message being ACK'ed
; "ERR",# - Error field defined on failure
;
N DGCNT
;
S DGORR("ACKCODE")=$G(DGSEG(1))
S DGORR("MSGID")=$G(DGSEG(2))
I DGORR("ACKCODE")'="AA",$G(DGSEG(6))]"" D
. S DGCNT=$O(DGORR("ERR",""),-1),DGCNT=DGCNT+1
. S DGORR("ERR",DGCNT)=$P(DGSEG(6),DGCS,1)
Q
;
SENDBULL(DGLIEN,DGORR) ;build and send error bulletin
;
; Input:
; DGLIEN - IEN of VIC HL7 TRANSMISSION LOG (#39.7)
; DGORR - array of parsed ACK results
; "SNDFAC" - sending facility
; "RCVFAC" - receiving facility
; "MSGDTM" - message creation date/time in FileMan format
; "ACKCODE" - Acknowledgment code
; "MSGID" - Message Control ID of the message being ACK'ed
; "ERR",# - Error field defined on failure
;
; Output:
; none
;
N XMB ;name of bulletin and parameter array
N XMDUZ ;sending user
N XMSUB ;bulletin subject
N XMTEXT ;additional text for rejection reasons
N DGLOG ;VIC HL7 TRANSMISSION LOG data array
N DGREQ ;VIC REQUEST data array
;
I +$G(DGLIEN) D
. ;
. ;retrieve HL7 LOG data
. Q:'$$GETLOG^DGQEHLL(DGLIEN,.DGLOG)
. ;
. ;retrieve VIC REQUEST data
. Q:'$$GETREQ^DGQEREQ($G(DGLOG("REQIEN")),.DGREQ)
. ;
. ;load bulletin params
. S XMB(1)=$$FMTE^XLFDT($$NOW^XLFDT())
. S XMB(2)=$G(DGREQ("NAME"))
. S XMB(3)=$G(DGREQ("CARDID"))
. S XMB(4)=$S($G(DGREQ("CPRSTAT"))="P":"Release and print previously held VIC request",1:"Cancel VIC request")
. S XMB(5)=$G(DGLOG("HLMID"))
. S XMB(6)=$$FMTE^XLFDT($G(DGLOG("XMITDT")))
. I $D(DGORR("ERR")) D
. . S XMTEXT=$NA(^TMP("DGQEBULL",$J))
. . K @XMTEXT
. . S @XMTEXT@(1)=" "
. . S @XMTEXT@(2)=" Reason(s) for rejection:"
. . S DGCNT=0
. . F S DGCNT=$O(DGORR("ERR",DGCNT)) Q:'DGCNT D
. . . S @XMTEXT@(DGCNT+2)=" #"_DGCNT_":"_" "_DGORR("ERR",DGCNT)
. ;
. S XMB="DGQE HL7ERR"
. S XMDUZ="VIC NCMD HL7 INTERFACE MODULE"
. S XMSUB="VIC HL7 ERROR"
. D ^XMB
. I $G(XMTEXT)]"" K @XMTEXT
Q
DGQEHLR ;ALB/RPM - VIC REPLACEMENT HL7 RECEIVE DRIVER ; 10/6/03
+1 ;;5.3;Registration;**571,1015**;Aug 13, 1993;Build 21
+2 ;
RCV ;
+1 NEW DGCNT
+2 NEW DGMSGTYP
+3 NEW DGSEG
+4 NEW DGSEGCNT
+5 NEW DGWRK
+6 ;
+7 SET DGWRK=$NAME(^TMP("DGPFHL7",$JOB))
+8 KILL @DGWRK
+9 ;
+10 ;load work global with segments
+11 FOR DGSEGCNT=1:1
XECUTE HLNEXT
IF HLQUIT'>0
QUIT
Begin DoDot:1
+12 SET DGCNT=0
+13 SET @DGWRK@(DGSEGCNT,DGCNT)=HLNODE
+14 FOR
SET DGCNT=$ORDER(HLNODE(DGCNT))
IF 'DGCNT
QUIT
Begin DoDot:2
+15 SET @DGWRK@(DGSEGCNT,DGCNT)=HLNODE(DGCNT)
End DoDot:2
End DoDot:1
+16 ;
+17 ;get message type from first segment
+18 IF $$NXTSEG^DGQEHLUT(DGWRK,0,HL("FS"),.DGSEG)
IF $GET(DGSEG("TYPE"))="MSH"
Begin DoDot:1
+19 SET DGMSGTYP=$PIECE(DGSEG(9),$EXTRACT(HL("ECH"),1),1)
+20 IF DGMSGTYP=HL("MTN")
DO RCVORR(DGWRK,.HL)
End DoDot:1
+21 ;
+22 ;cleanup
+23 KILL @DGWRK
+24 QUIT
+25 ;
RCVORR(DGWRK,DGHL) ;process a single ORR~O02 message
+1 ;
+2 ; Input:
+3 ; DGWRK - temporary segment work array
+4 ; DGHL - VistA HL7 environment array
+5 ;
+6 ; Output:
+7 ; none
+8 ;
+9 NEW DGORR
+10 NEW DGLIEN
+11 NEW DGSTAT
+12 ;
+13 DO PARSORR(DGWRK,.DGHL,.DGORR)
+14 ;
+15 IF +$GET(DGORR("MSGID"))
IF $GET(DGORR("ACKCODE"))]""
Begin DoDot:1
+16 SET DGLIEN=$$FINDMID^DGQEHLL(DGORR("MSGID"))
+17 IF 'DGLIEN
QUIT
+18 ;
+19 IF DGORR("ACKCODE")="AA"
SET DGSTAT="A"
+20 IF '$TEST
Begin DoDot:2
+21 SET DGSTAT="RJ"
+22 ;send bulletin indicating failed NCMD update
+23 DO SENDBULL(DGLIEN,.DGORR)
End DoDot:2
+24 ;
+25 ;remove "H"old event entry from VIC HL7 TRANSMISSION LOG (#39.6) file
+26 DO STOACK^DGQEHLL(DGLIEN,DGSTAT)
End DoDot:1
+27 ;
+28 QUIT
+29 ;
PARSORR(DGWRK,DGHL,DGORR) ;Parse ORR Message/Segments
+1 ;
+2 ; Input:
+3 ; DGWRK - Closed root work global reference
+4 ; DGHL - HL7 environment array
+5 ;
+6 ; Output:
+7 ; DGORR - array of ACK results
+8 ;
+9 NEW DGFS
+10 NEW DGCS
+11 NEW DGRS
+12 NEW DGSS
+13 NEW DGCURLIN
+14 ;
+15 SET DGFS=DGHL("FS")
+16 SET DGCS=$EXTRACT(DGHL("ECH"),1)
+17 SET DGRS=$EXTRACT(DGHL("ECH"),2)
+18 SET DGSS=$EXTRACT(DGHL("ECH"),4)
+19 SET DGCURLIN=0
+20 ;
+21 ;loop through the message segments and retrieve the field data
+22 FOR
Begin DoDot:1
+23 NEW DGSEG
+24 SET DGCURLIN=$$NXTSEG^DGQEHLUT(DGWRK,DGCURLIN,DGFS,.DGSEG)
+25 IF 'DGCURLIN
QUIT
+26 DO @(DGSEG("TYPE")_"(.DGSEG,DGCS,DGRS,DGSS,.DGORR)")
End DoDot:1
IF 'DGCURLIN
QUIT
+27 QUIT
+28 ;
MSH(DGSEG,DGCS,DGRS,DGSS,DGORR) ;
+1 ;
+2 ; Input:
+3 ; DGSEG - MSH segment field array
+4 ; DGCS - HL7 component separator
+5 ; DGRS - HL7 repetition separator
+6 ; DGSS - HL7 sub-component separator
+7 ;
+8 ; Output:
+9 ; DGORR - array of ACK results
+10 ; "SNDFAC" - sending facility
+11 ; "RCVFAC" - receiving facility
+12 ; "MSGDTM" - message creation date/time in FileMan format
+13 ;
+14 SET DGORR("SNDFAC")=$PIECE($GET(DGSEG(4)),DGCS,1)
+15 SET DGORR("RCVFAC")=$PIECE($GET(DGSEG(6)),DGCS,1)
+16 SET DGORR("MSGDTM")=$$HL7TFM^XLFDT($GET(DGSEG(7)))
+17 QUIT
+18 ;
MSA(DGSEG,DGCS,DGRS,DGSS,DGORR) ;
+1 ;
+2 ; Input:
+3 ; DGSEG - MSH segment field array
+4 ; DGCS - HL7 component separator
+5 ; DGRS - HL7 repetition separator
+6 ; DGSS - HL7 sub-component separator
+7 ;
+8 ; Output:
+9 ; DGORR - array of ACK results
+10 ; "ACKCODE" - Acknowledgment code
+11 ; "MSGID" - Message Control ID of the message being ACK'ed
+12 ; "ERR",# - Error field defined on failure
+13 ;
+14 NEW DGCNT
+15 ;
+16 SET DGORR("ACKCODE")=$GET(DGSEG(1))
+17 SET DGORR("MSGID")=$GET(DGSEG(2))
+18 IF DGORR("ACKCODE")'="AA"
IF $GET(DGSEG(6))]""
Begin DoDot:1
+19 SET DGCNT=$ORDER(DGORR("ERR",""),-1)
SET DGCNT=DGCNT+1
+20 SET DGORR("ERR",DGCNT)=$PIECE(DGSEG(6),DGCS,1)
End DoDot:1
+21 QUIT
+22 ;
SENDBULL(DGLIEN,DGORR) ;build and send error bulletin
+1 ;
+2 ; Input:
+3 ; DGLIEN - IEN of VIC HL7 TRANSMISSION LOG (#39.7)
+4 ; DGORR - array of parsed ACK results
+5 ; "SNDFAC" - sending facility
+6 ; "RCVFAC" - receiving facility
+7 ; "MSGDTM" - message creation date/time in FileMan format
+8 ; "ACKCODE" - Acknowledgment code
+9 ; "MSGID" - Message Control ID of the message being ACK'ed
+10 ; "ERR",# - Error field defined on failure
+11 ;
+12 ; Output:
+13 ; none
+14 ;
+15 ;name of bulletin and parameter array
NEW XMB
+16 ;sending user
NEW XMDUZ
+17 ;bulletin subject
NEW XMSUB
+18 ;additional text for rejection reasons
NEW XMTEXT
+19 ;VIC HL7 TRANSMISSION LOG data array
NEW DGLOG
+20 ;VIC REQUEST data array
NEW DGREQ
+21 ;
+22 IF +$GET(DGLIEN)
Begin DoDot:1
+23 ;
+24 ;retrieve HL7 LOG data
+25 IF '$$GETLOG^DGQEHLL(DGLIEN,.DGLOG)
QUIT
+26 ;
+27 ;retrieve VIC REQUEST data
+28 IF '$$GETREQ^DGQEREQ($GET(DGLOG("REQIEN")),.DGREQ)
QUIT
+29 ;
+30 ;load bulletin params
+31 SET XMB(1)=$$FMTE^XLFDT($$NOW^XLFDT())
+32 SET XMB(2)=$GET(DGREQ("NAME"))
+33 SET XMB(3)=$GET(DGREQ("CARDID"))
+34 SET XMB(4)=$SELECT($GET(DGREQ("CPRSTAT"))="P":"Release and print previously held VIC request",1:"Cancel VIC request")
+35 SET XMB(5)=$GET(DGLOG("HLMID"))
+36 SET XMB(6)=$$FMTE^XLFDT($GET(DGLOG("XMITDT")))
+37 IF $DATA(DGORR("ERR"))
Begin DoDot:2
+38 SET XMTEXT=$NAME(^TMP("DGQEBULL",$JOB))
+39 KILL @XMTEXT
+40 SET @XMTEXT@(1)=" "
+41 SET @XMTEXT@(2)=" Reason(s) for rejection:"
+42 SET DGCNT=0
+43 FOR
SET DGCNT=$ORDER(DGORR("ERR",DGCNT))
IF 'DGCNT
QUIT
Begin DoDot:3
+44 SET @XMTEXT@(DGCNT+2)=" #"_DGCNT_":"_" "_DGORR("ERR",DGCNT)
End DoDot:3
End DoDot:2
+45 ;
+46 SET XMB="DGQE HL7ERR"
+47 SET XMDUZ="VIC NCMD HL7 INTERFACE MODULE"
+48 SET XMSUB="VIC HL7 ERROR"
+49 DO ^XMB
+50 IF $GET(XMTEXT)]""
KILL @XMTEXT
End DoDot:1
+51 QUIT
