BEHODC7 ;MSC/IND/MGH - TIU Dictation Support ;20-Mar-2007 13:48;DKM
;;1.1;BEH COMPONENTS;**001001**;Mar 20, 2007
;=================================================================
;This is the main processing routine of the message that was
;received through HL7 and is intended to be stored in TIU
;=================================================================
PROCESS ;EP - Get message one line at a time
N BEHDOC,BEHDOCID,BEHTEMP,ERRTX,BEHORIFN,X,J,DTO,DATE,Y,SEP,LINE
N BEHEXAM,%,NEXT,SET,SUCCESS,HLMG,BEHTYPE,BEHSTAT,BEHID
N BEHLOC,BEHDATE,BEHFILER,BEHPLACE,BEHREC,BEHI,BEHCASE,BEHSTORE
N TIUPT,TIUDOC,TITLE,SEQ
S ERRTX=""
S X=$G(MSG(BEHNUM)) I $E(X,1,3)'="PID" S ERRTX="PID not second record." D BOTH^BEHODC8("",EVNDT,ERRTX) G KIL^BEHODC6
;Get patient IEN
D PID^BEHODC6
I DFN>0 D
. S BEHNUM=BEHNUM+1
.I $E(MSG(BEHNUM),1,3)="ORC" D
..D ORC
Q
ORC ; Check ORC
;==================================================================
S X=$G(MSG(BEHNUM))
I $E(X,1,3)'="ORC" S ERRTX="ORC not found when expected. Contact IRM or Proscribe" D BOTH^BEHODC8(DFN,EVNDT,ERRTX) G KIL^BEHODC6
S BEHID=$P(X,HLFS,3) ;This is the unique TIU IEN sent over
S BEHNUM=BEHNUM+1
OBR ; Check OBR
;====================================================================
;The items needed from the OBR are:
;1) The unique document ID
;2) The author and signer of the note
;3) The note title
;===================================================================
N BEHNEW,BEHPLACE,BEHFILER,BEHSIGN,BEHSDOC,BEHUTHOR,BEHUTHID,BEHSTAT
S BEHNEW=0
S X=$G(MSG(BEHNUM))
S SEG("OBR")=X
I $E(X,1,3)'="OBR" S ERRTX="OBR not found when expected. Contact IRM or Proscribe" D BOTH^BEHODC8(DFN,EVNDT,ERRTX) G KIL^BEHODC6
S BEHSTAT=$P(X,HLFS,26)
;Only accept final versions
I (BEHSTAT'="F")&(BEHSTAT'="C") S ERRTX="Report send was not a final version. Please resend" D BOTH^BEHODC8(DFN,EVNDT,ERRTX) G KIL^BEHODC6
S TIUDA=$P(X,HLFS,3) ; This is the TIU IEN send over
I TIUDA="" S ERRTX="No unique note number was sent across. Resend message" D BOTH^BEHODC8(DFN,EVNDT,ERRTX) G KIL^BEHODC6
S BEHPLACE=$P(X,HLFS,3),BEHFILER=$P(X,HLFS,4)
;=================================================================
;Find the author and the signer of the note
;=================================================================
S BEHSIGN=$P($G(X),HLFS,33) I BEHSIGN'="" S BEHDOCID=$P(BEHSIGN,HLSUB,1)
I '$D(^VA(200,BEHDOCID,0)) S ERRTX="Signer ID "_BEHDOCID_" not valid in "_$$AGTEXT()_". Call IRM and check data." D BOTH^BEHODC8(DFN,EVNDT,ERRTX) G KIL^BEHODC6
S BEHUTHOR=$P($G(X),HLFS,34) I BEHUTHOR'="" S BEHUTHID=$P(BEHUTHOR,HLSUB,1)
I '$D(^VA(200,BEHUTHID,0)) S ERRTX="Author ID "_BEHUTHID_" not valid in "_$$AGTEXT()_". Call IRM and check data." D BOTH^BEHODC8(DFN,EVNDT,ERRTX) G KIL^BEHODC6
S TIUX(1202)=BEHDOCID
S TIUX(1204)=BEHUTHID
;====================================================================
;Get the title of the note
;===================================================================
S (BEHEXAM,%)=$P(X,HLFS,5)
I $P(BEHEXAM,HLCOMP,2)="TIU Note" S TIUEXAM="TIU Note"
E D
.I BEHEXAM'="" S TIUTITLE=$P(%,HLCOMP,2) I BEHEXAM="" S TIUTITLE=$P(%,HLCOMP,1)
.I TIUTITLE'="" S TIUTITLE=$$UPPER^TIULS(TIUTITLE) S TIUEXAM=$O(^TIU(8925.1,"B",TIUTITLE,0))
.I TIUTITLE="" S ERRTX="No title given to this exam. Please resend" D BOTH^BEHODC8(DFN,EVNDT,ERRTX) G KIL^BEHODC6
;Compare with the found results
;=======================================================================
;Check the data in the note IEN against the data in the message
;Make sure that the patient, author and title match
;=======================================================================
S TIUX(.03)=$P($G(^TIU(8925,TIUDA,0)),U,3)
S TIUPT=$P($G(^TIU(8925,TIUDA,0)),U,2)
;Title from TIU document
S TIUDOC=$P($G(^TIU(8925,TIUDA,0)),U,1)
I TIUEXAM'="TIU Note" D
.I TIUDOC'=TIUEXAM S ERRTX="Document titles do not match" D BOTH^BEHODC8(DFN,EVNDT,ERRTX) G KIL^BEHODC6
S TIUAUTH=$P($G(^TIU(8925,TIUDA,12)),U,2)
I TIUPT'=DFN S ERRTX="Patients do not match. resend document" D BOTH^BEHODC8(DFN,EVNDT,ERRTX) G KIL^BEHODC6
I TIUAUTH'=BEHUTHID S ERRTX="The autors of the documents do not match" D BOTH^BEHODC8(DFN,EVNDT,ERRTX) G KIL^BEHODC6
S BEHNUM=BEHNUM+1
I ERRTX'="" D BOTH^BEHODC8(DFN,EVNDT,ERRTX) Q
OBX ; Process OBX
S BEHI=0
S X=$G(MSG(BEHNUM))
S SEG("OBX")=X
I $E(X,1,3)'="OBX" S ERRTX="OBX not found when expected. Contact IRM" D BOTH^BEHODC8(DFN,EVNDT,ERRTX) G KIL^BEHODC6
S BEHI=1
D GETOBX
Q
NEXT S BEHNUM=BEHNUM+1
I '$D(MSG(BEHNUM)) G UPDATE
I $E(MSG(BEHNUM),1,3)="OBX" G GETOBX^BEHODC7
E S ERRTX="UNKNOWN MESSAGE SEGMENT" D BOTH^BEHODC8(DFN,EVNDT,ERRTX) G KIL^BEHODC6
Q
GETOBX ;EP - Get the OBX data to store
S SEQ=$P(MSG(BEHNUM),HLFS,2)
S LINE=$P(MSG(BEHNUM),HLFS,6)
I BEHI=SEQ D
.I LINE="" S LINE=" "
.S TIUX("TEXT",BEHI,0)=LINE
.S BEHI=BEHI+1
G NEXT
Q
UPDATE ;End of text; call routine to file data
;Since the stub of the note was already created in the EHR
;this is only an update. The text of the note will be replaced
;if the note is unsigned. If the note was signed, the text will become an addendum
;======================================================================
D UPDATE^TIUSRVP(.SUCCESS,TIUDA,.TIUX,"")
I $P(SUCCESS,"^",1)>0 D
.S HLMG=SUCCESS
.S TIUD0=$G(^TIU(8925,SUCCESS,0))
.I +$P(TIUD0,U,5)<5 D UPDSTAT^TIUSRVP(SUCCESS,+$G(TIUD0))
.D SEND^TIUALRT(SUCCESS)
E S ERRTX=$P(SUCCESS,"^",2) D BOTH^BEHODC8(DFN,EVNDT,ERRTX) G KIL^BEHODC6
D GENACK^BEHODC8
D KIL
Q
KIL ; Kill Variables
G KIL^BEHODC6
; Return Agency specific text
AGTEXT() ; EP
Q $S($P($G(^XTV(8989.3,1,0)),U,8)="I":"RPMS",1:"VISTA")
BEHODC7 ;MSC/IND/MGH - TIU Dictation Support ;20-Mar-2007 13:48;DKM
+1 ;;1.1;BEH COMPONENTS;**001001**;Mar 20, 2007
+2 ;=================================================================
+3 ;This is the main processing routine of the message that was
+4 ;received through HL7 and is intended to be stored in TIU
+5 ;=================================================================
PROCESS ;EP - Get message one line at a time
+1 NEW BEHDOC,BEHDOCID,BEHTEMP,ERRTX,BEHORIFN,X,J,DTO,DATE,Y,SEP,LINE
+2 NEW BEHEXAM,%,NEXT,SET,SUCCESS,HLMG,BEHTYPE,BEHSTAT,BEHID
+3 NEW BEHLOC,BEHDATE,BEHFILER,BEHPLACE,BEHREC,BEHI,BEHCASE,BEHSTORE
+4 NEW TIUPT,TIUDOC,TITLE,SEQ
+5 SET ERRTX=""
+6 SET X=$GET(MSG(BEHNUM))
IF $EXTRACT(X,1,3)'="PID"
SET ERRTX="PID not second record."
DO BOTH^BEHODC8("",EVNDT,ERRTX)
GOTO KIL^BEHODC6
+7 ;Get patient IEN
+8 DO PID^BEHODC6
+9 IF DFN>0
Begin DoDot:1
+10 SET BEHNUM=BEHNUM+1
+11 IF $EXTRACT(MSG(BEHNUM),1,3)="ORC"
Begin DoDot:2
+12 DO ORC
End DoDot:2
End DoDot:1
+13 QUIT
ORC ; Check ORC
+1 ;==================================================================
+2 SET X=$GET(MSG(BEHNUM))
+3 IF $EXTRACT(X,1,3)'="ORC"
SET ERRTX="ORC not found when expected. Contact IRM or Proscribe"
DO BOTH^BEHODC8(DFN,EVNDT,ERRTX)
GOTO KIL^BEHODC6
+4 ;This is the unique TIU IEN sent over
SET BEHID=$PIECE(X,HLFS,3)
+5 SET BEHNUM=BEHNUM+1
OBR ; Check OBR
+1 ;====================================================================
+2 ;The items needed from the OBR are:
+3 ;1) The unique document ID
+4 ;2) The author and signer of the note
+5 ;3) The note title
+6 ;===================================================================
+7 NEW BEHNEW,BEHPLACE,BEHFILER,BEHSIGN,BEHSDOC,BEHUTHOR,BEHUTHID,BEHSTAT
+8 SET BEHNEW=0
+9 SET X=$GET(MSG(BEHNUM))
+10 SET SEG("OBR")=X
+11 IF $EXTRACT(X,1,3)'="OBR"
SET ERRTX="OBR not found when expected. Contact IRM or Proscribe"
DO BOTH^BEHODC8(DFN,EVNDT,ERRTX)
GOTO KIL^BEHODC6
+12 SET BEHSTAT=$PIECE(X,HLFS,26)
+13 ;Only accept final versions
+14 IF (BEHSTAT'="F")&(BEHSTAT'="C")
SET ERRTX="Report send was not a final version. Please resend"
DO BOTH^BEHODC8(DFN,EVNDT,ERRTX)
GOTO KIL^BEHODC6
+15 ; This is the TIU IEN send over
SET TIUDA=$PIECE(X,HLFS,3)
+16 IF TIUDA=""
SET ERRTX="No unique note number was sent across. Resend message"
DO BOTH^BEHODC8(DFN,EVNDT,ERRTX)
GOTO KIL^BEHODC6
+17 SET BEHPLACE=$PIECE(X,HLFS,3)
SET BEHFILER=$PIECE(X,HLFS,4)
+18 ;=================================================================
+19 ;Find the author and the signer of the note
+20 ;=================================================================
+21 SET BEHSIGN=$PIECE($GET(X),HLFS,33)
IF BEHSIGN'=""
SET BEHDOCID=$PIECE(BEHSIGN,HLSUB,1)
+22 IF '$DATA(^VA(200,BEHDOCID,0))
SET ERRTX="Signer ID "_BEHDOCID_" not valid in "_$$AGTEXT()_". Call IRM and check data."
DO BOTH^BEHODC8(DFN,EVNDT,ERRTX)
GOTO KIL^BEHODC6
+23 SET BEHUTHOR=$PIECE($GET(X),HLFS,34)
IF BEHUTHOR'=""
SET BEHUTHID=$PIECE(BEHUTHOR,HLSUB,1)
+24 IF '$DATA(^VA(200,BEHUTHID,0))
SET ERRTX="Author ID "_BEHUTHID_" not valid in "_$$AGTEXT()_". Call IRM and check data."
DO BOTH^BEHODC8(DFN,EVNDT,ERRTX)
GOTO KIL^BEHODC6
+25 SET TIUX(1202)=BEHDOCID
+26 SET TIUX(1204)=BEHUTHID
+27 ;====================================================================
+28 ;Get the title of the note
+29 ;===================================================================
+30 SET (BEHEXAM,%)=$PIECE(X,HLFS,5)
+31 IF $PIECE(BEHEXAM,HLCOMP,2)="TIU Note"
SET TIUEXAM="TIU Note"
+32 IF '$TEST
Begin DoDot:1
+33 IF BEHEXAM'=""
SET TIUTITLE=$PIECE(%,HLCOMP,2)
IF BEHEXAM=""
SET TIUTITLE=$PIECE(%,HLCOMP,1)
+34 IF TIUTITLE'=""
SET TIUTITLE=$$UPPER^TIULS(TIUTITLE)
SET TIUEXAM=$ORDER(^TIU(8925.1,"B",TIUTITLE,0))
+35 IF TIUTITLE=""
SET ERRTX="No title given to this exam. Please resend"
DO BOTH^BEHODC8(DFN,EVNDT,ERRTX)
GOTO KIL^BEHODC6
End DoDot:1
+36 ;Compare with the found results
+37 ;=======================================================================
+38 ;Check the data in the note IEN against the data in the message
+39 ;Make sure that the patient, author and title match
+40 ;=======================================================================
+41 SET TIUX(.03)=$PIECE($GET(^TIU(8925,TIUDA,0)),U,3)
+42 SET TIUPT=$PIECE($GET(^TIU(8925,TIUDA,0)),U,2)
+43 ;Title from TIU document
+44 SET TIUDOC=$PIECE($GET(^TIU(8925,TIUDA,0)),U,1)
+45 IF TIUEXAM'="TIU Note"
Begin DoDot:1
+46 IF TIUDOC'=TIUEXAM
SET ERRTX="Document titles do not match"
DO BOTH^BEHODC8(DFN,EVNDT,ERRTX)
GOTO KIL^BEHODC6
End DoDot:1
+47 SET TIUAUTH=$PIECE($GET(^TIU(8925,TIUDA,12)),U,2)
+48 IF TIUPT'=DFN
SET ERRTX="Patients do not match. resend document"
DO BOTH^BEHODC8(DFN,EVNDT,ERRTX)
GOTO KIL^BEHODC6
+49 IF TIUAUTH'=BEHUTHID
SET ERRTX="The autors of the documents do not match"
DO BOTH^BEHODC8(DFN,EVNDT,ERRTX)
GOTO KIL^BEHODC6
+50 SET BEHNUM=BEHNUM+1
+51 IF ERRTX'=""
DO BOTH^BEHODC8(DFN,EVNDT,ERRTX)
QUIT
OBX ; Process OBX
+1 SET BEHI=0
+2 SET X=$GET(MSG(BEHNUM))
+3 SET SEG("OBX")=X
+4 IF $EXTRACT(X,1,3)'="OBX"
SET ERRTX="OBX not found when expected. Contact IRM"
DO BOTH^BEHODC8(DFN,EVNDT,ERRTX)
GOTO KIL^BEHODC6
+5 SET BEHI=1
+6 DO GETOBX
+7 QUIT
NEXT SET BEHNUM=BEHNUM+1
+1 IF '$DATA(MSG(BEHNUM))
GOTO UPDATE
+2 IF $EXTRACT(MSG(BEHNUM),1,3)="OBX"
GOTO GETOBX^BEHODC7
+3 IF '$TEST
SET ERRTX="UNKNOWN MESSAGE SEGMENT"
DO BOTH^BEHODC8(DFN,EVNDT,ERRTX)
GOTO KIL^BEHODC6
+4 QUIT
GETOBX ;EP - Get the OBX data to store
+1 SET SEQ=$PIECE(MSG(BEHNUM),HLFS,2)
+2 SET LINE=$PIECE(MSG(BEHNUM),HLFS,6)
+3 IF BEHI=SEQ
Begin DoDot:1
+4 IF LINE=""
SET LINE=" "
+5 SET TIUX("TEXT",BEHI,0)=LINE
+6 SET BEHI=BEHI+1
End DoDot:1
+7 GOTO NEXT
+8 QUIT
UPDATE ;End of text; call routine to file data
+1 ;Since the stub of the note was already created in the EHR
+2 ;this is only an update. The text of the note will be replaced
+3 ;if the note is unsigned. If the note was signed, the text will become an addendum
+4 ;======================================================================
+5 DO UPDATE^TIUSRVP(.SUCCESS,TIUDA,.TIUX,"")
+6 IF $PIECE(SUCCESS,"^",1)>0
Begin DoDot:1
+7 SET HLMG=SUCCESS
+8 SET TIUD0=$GET(^TIU(8925,SUCCESS,0))
+9 IF +$PIECE(TIUD0,U,5)<5
DO UPDSTAT^TIUSRVP(SUCCESS,+$GET(TIUD0))
+10 DO SEND^TIUALRT(SUCCESS)
End DoDot:1
+11 IF '$TEST
SET ERRTX=$PIECE(SUCCESS,"^",2)
DO BOTH^BEHODC8(DFN,EVNDT,ERRTX)
GOTO KIL^BEHODC6
+12 DO GENACK^BEHODC8
+13 DO KIL
+14 QUIT
KIL ; Kill Variables
+1 GOTO KIL^BEHODC6
+2 ; Return Agency specific text
AGTEXT() ; EP
+1 QUIT $SELECT($PIECE($GET(^XTV(8989.3,1,0)),U,8)="I":"RPMS",1:"VISTA")
