RMPRFC3 ;HINES CIOFO/HNC - Process IFC HL7 ; 2/6/09
;;3.0;PROSTHETICS;**83,193,198**;Feb 09,1996;Build 6
;
;
;Helen Corkwell-new flow 3/9/05
;
; Patch 83 -
; - Prohibit filing data in 668 if code runs at sending site
; - Exit if NW record in consults and 668; and if DC and is dup
;
Q
EN ;process IFC responses
;load message in ^TMP
K ^TMP("RMPRIF",$J)
N HLNODE,SEG,I ;production code
N RMPRSITIEN,RMPRSTA
F I=1:1 X HLNEXT Q:HLQUIT'>0 D
.I $P(HLNODE,"|")="OBX" D
..S ^TMP("RMPRIF",$J,"OBX",$P(HLNODE,"|",2),$P(HLNODE,"|",5))=$E(HLNODE,5,999)
.I $P(HLNODE,"|")="NTE" D
..S ^TMP("RMPRIF",$J,"NTE",$P(HLNODE,"|",2))=$E(HLNODE,5,999)
.I "OBXNTE"'[$P(HLNODE,"|") D
..S ^TMP("RMPRIF",$J,$P(HLNODE,"|"))=$E(HLNODE,5,999)
;
CHK ;
;DC does not have a OBR segment, must check status first
;
;
;is it a NW or DC order?
I '$D(^TMP("RMPRIF",$J,"ORC")) G EXIT
S RMPRST=$P(^TMP("RMPRIF",$J,"ORC"),"|",1)
I RMPRST="OD" S RMPRST=$P(^TMP("RMPRIF",$J,"ORC"),"|",5)
I (RMPRST'="NW")&(RMPRST'="DC") G EXIT
;
I '$D(^TMP("RMPRIF",$J,"OBR"))&(RMPRST'="DC") G EXIT
I RMPRST="NW"&($P($G(^TMP("RMPRIF",$J,"OBR")),"|",4)'["PROSTHETICS IFC") G EXIT
;
;is it a discontinued order? does it have a consult ien?
;is there a local consult ien? has it already been filed in 668?
I RMPRST="NW" D
.S RMPR123=$P(^TMP("RMPRIF",$J,"OBR"),"|",2)
.S RMPR123I=$P(RMPR123,U,1),RMPRISIT=$P(RMPR123,U,2)
;
I RMPRST="DC" D
.S RMPR123=$P(^TMP("RMPRIF",$J,"ORC"),"|",3)
.S RMPR123I=$P(RMPR123,U,1),RMPRISIT=$P(RMPR123,U,2)
.S RMPR123A=RMPR123I
TST ;
;Consult IEN
D FIND^DIC(4,,99,,RMPRISIT,1,"D",,,"RMPRSTA")
S RMPRSITIEN=$G(RMPRSTA("DILIST",2,1)) ;RMPR*3.0*198 sets the institution IEN for discontinued and new consults
I RMPRST="NW" D
.S RMPR123A=$O(^GMR(123,"AIFC",RMPRSITIEN,RMPR123I,0))
;
I RMPR123A="" G EXIT
;added check, when HL7 link is down possible to get mult NW msg
;8/23/05 hnc
; modified check, EXIT imm. on NW message, loop On 668 "D" xref to determine if dup DC
; 13 MAR 09 DDA
I RMPRST="NW" G:$D(^RMPR(668,"D",RMPR123A)) EXIT
I RMPRST="DC" S RMPRDPDC=0 D
.S RMPRDCIN="" F S RMPRDCIN=$O(^RMPR(668,"D",RMPR123A,RMPRDCIN)) Q:RMPRDCIN="" D
..S:^RMPR(668,RMPRDCIN,2,1,0)["****DISCONTINUED****" RMPRDPDC=1
..Q
.Q
I $G(RMPRDPDC)=1 G EXIT
S ^TMP("RMPRIF",$J,"GOODTOGO")="OKAY"
G EN^RMPRFC4
Q
;
EXIT ;common exit point
K ^TMP("RMPRIF",$J)
G EXIT^RMPRFC4
;END
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRFC3 2487 printed Apr 09, 2024@21:37:06 Page 2
RMPRFC3 ;HINES CIOFO/HNC - Process IFC HL7 ; 2/6/09
+1 ;;3.0;PROSTHETICS;**83,193,198**;Feb 09,1996;Build 6
+2 ;
+3 ;
+4 ;Helen Corkwell-new flow 3/9/05
+5 ;
+6 ; Patch 83 -
+7 ; - Prohibit filing data in 668 if code runs at sending site
+8 ; - Exit if NW record in consults and 668; and if DC and is dup
+9 ;
+10 QUIT
EN ;process IFC responses
+1 ;load message in ^TMP
+2 KILL ^TMP("RMPRIF",$JOB)
+3 ;production code
NEW HLNODE,SEG,I
+4 NEW RMPRSITIEN,RMPRSTA
+5 FOR I=1:1
XECUTE HLNEXT
if HLQUIT'>0
QUIT
Begin DoDot:1
+6 IF $PIECE(HLNODE,"|")="OBX"
Begin DoDot:2
+7 SET ^TMP("RMPRIF",$JOB,"OBX",$PIECE(HLNODE,"|",2),$PIECE(HLNODE,"|",5))=$EXTRACT(HLNODE,5,999)
End DoDot:2
+8 IF $PIECE(HLNODE,"|")="NTE"
Begin DoDot:2
+9 SET ^TMP("RMPRIF",$JOB,"NTE",$PIECE(HLNODE,"|",2))=$EXTRACT(HLNODE,5,999)
End DoDot:2
+10 IF "OBXNTE"'[$PIECE(HLNODE,"|")
Begin DoDot:2
+11 SET ^TMP("RMPRIF",$JOB,$PIECE(HLNODE,"|"))=$EXTRACT(HLNODE,5,999)
End DoDot:2
End DoDot:1
+12 ;
CHK ;
+1 ;DC does not have a OBR segment, must check status first
+2 ;
+3 ;
+4 ;is it a NW or DC order?
+5 IF '$DATA(^TMP("RMPRIF",$JOB,"ORC"))
GOTO EXIT
+6 SET RMPRST=$PIECE(^TMP("RMPRIF",$JOB,"ORC"),"|",1)
+7 IF RMPRST="OD"
SET RMPRST=$PIECE(^TMP("RMPRIF",$JOB,"ORC"),"|",5)
+8 IF (RMPRST'="NW")&(RMPRST'="DC")
GOTO EXIT
+9 ;
+10 IF '$DATA(^TMP("RMPRIF",$JOB,"OBR"))&(RMPRST'="DC")
GOTO EXIT
+11 IF RMPRST="NW"&($PIECE($GET(^TMP("RMPRIF",$JOB,"OBR")),"|",4)'["PROSTHETICS IFC")
GOTO EXIT
+12 ;
+13 ;is it a discontinued order? does it have a consult ien?
+14 ;is there a local consult ien? has it already been filed in 668?
+15 IF RMPRST="NW"
Begin DoDot:1
+16 SET RMPR123=$PIECE(^TMP("RMPRIF",$JOB,"OBR"),"|",2)
+17 SET RMPR123I=$PIECE(RMPR123,U,1)
SET RMPRISIT=$PIECE(RMPR123,U,2)
End DoDot:1
+18 ;
+19 IF RMPRST="DC"
Begin DoDot:1
+20 SET RMPR123=$PIECE(^TMP("RMPRIF",$JOB,"ORC"),"|",3)
+21 SET RMPR123I=$PIECE(RMPR123,U,1)
SET RMPRISIT=$PIECE(RMPR123,U,2)
+22 SET RMPR123A=RMPR123I
End DoDot:1
TST ;
+1 ;Consult IEN
+2 DO FIND^DIC(4,,99,,RMPRISIT,1,"D",,,"RMPRSTA")
+3 ;RMPR*3.0*198 sets the institution IEN for discontinued and new consults
SET RMPRSITIEN=$GET(RMPRSTA("DILIST",2,1))
+4 IF RMPRST="NW"
Begin DoDot:1
+5 SET RMPR123A=$ORDER(^GMR(123,"AIFC",RMPRSITIEN,RMPR123I,0))
End DoDot:1
+6 ;
+7 IF RMPR123A=""
GOTO EXIT
+8 ;added check, when HL7 link is down possible to get mult NW msg
+9 ;8/23/05 hnc
+10 ; modified check, EXIT imm. on NW message, loop On 668 "D" xref to determine if dup DC
+11 ; 13 MAR 09 DDA
+12 IF RMPRST="NW"
if $DATA(^RMPR(668,"D",RMPR123A))
GOTO EXIT
+13 IF RMPRST="DC"
SET RMPRDPDC=0
Begin DoDot:1
+14 SET RMPRDCIN=""
FOR
SET RMPRDCIN=$ORDER(^RMPR(668,"D",RMPR123A,RMPRDCIN))
if RMPRDCIN=""
QUIT
Begin DoDot:2
+15 if ^RMPR(668,RMPRDCIN,2,1,0)["****DISCONTINUED****"
SET RMPRDPDC=1
+16 QUIT
End DoDot:2
+17 QUIT
End DoDot:1
+18 IF $GET(RMPRDPDC)=1
GOTO EXIT
+19 SET ^TMP("RMPRIF",$JOB,"GOODTOGO")="OKAY"
+20 GOTO EN^RMPRFC4
+21 QUIT
+22 ;
EXIT ;common exit point
+1 KILL ^TMP("RMPRIF",$JOB)
+2 GOTO EXIT^RMPRFC4
+3 ;END
