BEHODC6 ;MSC/IND/MGH - TIU Dictation Support ;20-Mar-2007 13:48;DKM
;;1.1;BEH COMPONENTS;**001001**;Mar 20, 2007
;=================================================================
;Routine processes message from PACS system for notes and stores them
;into TIU. The message is sent in an HL7 message with each line of the note
;a different OBX. The note IEN is being sent in the message
;=====================================================================
;
EN ;EP - Entry Point for Incoming Message Array in MSG
K MSG,ERRTX
N X,Y,EVNDT,TIUDA,TIUERR,TIUHDR,TIUPRM0,TIUPRM1,TIUI,J,BEHAPP,BEHRTN,BEHINST,BEHBID
N SSN,BEHSSN,BEHDPT,BEHHRN,BEHNAM,BEHN1,BEHN2,BEHDEF,BDATE1,BDATE2,LASTN1,LASTN2,TIME,X1,X2,BEHTIME
N TIUEDT,TIUAUTH,TIUTITLE,TIUD0,TIUEXAM,TIULOC,TIUX,BEHYR,I,PID,BEHNUM,VADM,TIUCASE
D SETPARM^TIULE S TIUI=0
;Read the entire message and store into the array MSG
F I=1:1 X HLNEXT Q:HLQUIT'>0 S MSG(I)=HLNODE,J=0 F S J=$O(HLNODE(J)) Q:'J S MSG(I,J)=HLNODE(J)
S BEHNUM=1
MSH ; Decode MSH
K SEG
S X="NOW" D ^%DT S EVNDT=Y
S HLFS=HL("FS"),HLCOMP=$E(HL("ECH")),HLSUB=$E(HL("ECH"),4,4)
I '$D(MSG(BEHNUM)) G KIL
S X=$G(MSG(BEHNUM)),SEG("MSH")=X,BEHAPP=""
I $E(X,1,3)'="MSH" S ERRTX="MSH not first record" D BOTH^BEHODC8(DFN,EVNDT,ERRTX) G KIL
S BEHAPP=$P(MSG(BEHNUM),HLFS,4) I BEHAPP="" G KIL
S BEHNUM=BEHNUM+1
D PROCESS^BEHODC7
Q
CVT ; Convert to FM date
Q:DATE=""
S BEHYR=$E(DATE,1,4)-1700,TIME=+$E(DATE,9,$L(DATE))
S DATE=BEHYR_$E(DATE,5,8)
I TIME,$E(TIME,1,2)=24 S X1=DATE,X2=1 D C^%DTC S DATE=X,TIME="0001"
K X1,X2
S DATE=DATE_$S(TIME:"."_TIME,1:"")
Q
PID ;EP - Check PID Need HRN
;Patient must match
S SEG("PID")=X
S BEHHRN=$P(X,HLFS,3)
S BEHDPT=$P(X,HLFS,4)
S BEHNAM=$P(X,HLFS,6),BEHSSN=$P(X,HLFS,20)
I 'BEHDPT S ERRTX="Patient ien"_BEHDPT_" not found in patient file. Please check data and resend." D BOTH^BEHODC8(DFN,EVNDT,ERRTX) Q
S DFN=BEHDPT
D PID^VADPT6 S PID=$G(VA("PID")),BEHBID=$G(VA("BID")) K VA
D DEM^VADPT
D CHECK
Q
CHECK ;Make checks on last name
S LASTN1=$P(BEHNAM,"^"),LASTN2=$P(VADM(1),",")
S BEHN1=$TR(LASTN1,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
S BEHN2=$TR(LASTN2,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
I BEHN1'=BEHN2 S ERRTX="Patient's last names do not match. "_$$AGTEXT^BEHODC7()_" has "_BEHN2_" and the COTs has "_BEHN1 D BOTH^BEHODC8(DFN,EVNDT,ERRTX)
Q
KIL ;EP - Kill Variables
S DFN=""
K MSG,BEHNUM,DATE,TIUAUTH,TIUDA,TIUEDT,TIUERR,TIUI,TIUTITLE,SEG
Q
BEHODC6 ;MSC/IND/MGH - TIU Dictation Support ;20-Mar-2007 13:48;DKM
+1 ;;1.1;BEH COMPONENTS;**001001**;Mar 20, 2007
+2 ;=================================================================
+3 ;Routine processes message from PACS system for notes and stores them
+4 ;into TIU. The message is sent in an HL7 message with each line of the note
+5 ;a different OBX. The note IEN is being sent in the message
+6 ;=====================================================================
+7 ;
EN ;EP - Entry Point for Incoming Message Array in MSG
+1 KILL MSG,ERRTX
+2 NEW X,Y,EVNDT,TIUDA,TIUERR,TIUHDR,TIUPRM0,TIUPRM1,TIUI,J,BEHAPP,BEHRTN,BEHINST,BEHBID
+3 NEW SSN,BEHSSN,BEHDPT,BEHHRN,BEHNAM,BEHN1,BEHN2,BEHDEF,BDATE1,BDATE2,LASTN1,LASTN2,TIME,X1,X2,BEHTIME
+4 NEW TIUEDT,TIUAUTH,TIUTITLE,TIUD0,TIUEXAM,TIULOC,TIUX,BEHYR,I,PID,BEHNUM,VADM,TIUCASE
+5 DO SETPARM^TIULE
SET TIUI=0
+6 ;Read the entire message and store into the array MSG
+7 FOR I=1:1
XECUTE HLNEXT
IF HLQUIT'>0
QUIT
SET MSG(I)=HLNODE
SET J=0
FOR
SET J=$ORDER(HLNODE(J))
IF 'J
QUIT
SET MSG(I,J)=HLNODE(J)
+8 SET BEHNUM=1
MSH ; Decode MSH
+1 KILL SEG
+2 SET X="NOW"
DO ^%DT
SET EVNDT=Y
+3 SET HLFS=HL("FS")
SET HLCOMP=$EXTRACT(HL("ECH"))
SET HLSUB=$EXTRACT(HL("ECH"),4,4)
+4 IF '$DATA(MSG(BEHNUM))
GOTO KIL
+5 SET X=$GET(MSG(BEHNUM))
SET SEG("MSH")=X
SET BEHAPP=""
+6 IF $EXTRACT(X,1,3)'="MSH"
SET ERRTX="MSH not first record"
DO BOTH^BEHODC8(DFN,EVNDT,ERRTX)
GOTO KIL
+7 SET BEHAPP=$PIECE(MSG(BEHNUM),HLFS,4)
IF BEHAPP=""
GOTO KIL
+8 SET BEHNUM=BEHNUM+1
+9 DO PROCESS^BEHODC7
+10 QUIT
CVT ; Convert to FM date
+1 IF DATE=""
QUIT
+2 SET BEHYR=$EXTRACT(DATE,1,4)-1700
SET TIME=+$EXTRACT(DATE,9,$LENGTH(DATE))
+3 SET DATE=BEHYR_$EXTRACT(DATE,5,8)
+4 IF TIME
IF $EXTRACT(TIME,1,2)=24
SET X1=DATE
SET X2=1
DO C^%DTC
SET DATE=X
SET TIME="0001"
+5 KILL X1,X2
+6 SET DATE=DATE_$SELECT(TIME:"."_TIME,1:"")
+7 QUIT
PID ;EP - Check PID Need HRN
+1 ;Patient must match
+2 SET SEG("PID")=X
+3 SET BEHHRN=$PIECE(X,HLFS,3)
+4 SET BEHDPT=$PIECE(X,HLFS,4)
+5 SET BEHNAM=$PIECE(X,HLFS,6)
SET BEHSSN=$PIECE(X,HLFS,20)
+6 IF 'BEHDPT
SET ERRTX="Patient ien"_BEHDPT_" not found in patient file. Please check data and resend."
DO BOTH^BEHODC8(DFN,EVNDT,ERRTX)
QUIT
+7 SET DFN=BEHDPT
+8 DO PID^VADPT6
SET PID=$GET(VA("PID"))
SET BEHBID=$GET(VA("BID"))
KILL VA
+9 DO DEM^VADPT
+10 DO CHECK
+11 QUIT
CHECK ;Make checks on last name
+1 SET LASTN1=$PIECE(BEHNAM,"^")
SET LASTN2=$PIECE(VADM(1),",")
+2 SET BEHN1=$TRANSLATE(LASTN1,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+3 SET BEHN2=$TRANSLATE(LASTN2,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+4 IF BEHN1'=BEHN2
SET ERRTX="Patient's last names do not match. "_$$AGTEXT^BEHODC7()_" has "_BEHN2_" and the COTs has "_BEHN1
DO BOTH^BEHODC8(DFN,EVNDT,ERRTX)
+5 QUIT
KIL ;EP - Kill Variables
+1 SET DFN=""
+2 KILL MSG,BEHNUM,DATE,TIUAUTH,TIUDA,TIUEDT,TIUERR,TIUI,TIUTITLE,SEG
+3 QUIT
