BEHODC6.m

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