- 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 Feb 19, 2025@00:01:07 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