BEHODC7.m

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")