GMRCRFC0 ;EHRM/JCH - Process IFC HL7 Messages; Jun 30, 2022@08:17:08
;;3.0;CONSULT/REQUEST TRACKING;**154,184**;DEC 27, 1997;Build 22
;
Q
EN(HLNEXT,HLQUIT) ;process IFC responses
;load message in ^TMP
K ^TMP("RMPRIF",$J)
N HLNODE,SEG,I
N %,RMPR123,RMPR123A,RMPR123I,RMPRISIT,RMPRST,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 ;
;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") D EXIT Q
;
I $P($G(^TMP("RMPRIF",$J,"OBR")),"|",4)'["PROSTHETICS IFC" D EXIT Q
;
;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
;When HL7 link is down possible to get mult NW msg
I RMPRST="NW" I $D(^RMPR(668,"D",RMPR123A)) D EXIT Q ; ICR #7131
S ^TMP("RMPRIF",$J,"GOODTOGO")="OKAY"
I RMPRST="DC" D Q
.N RMPRORC2,RMPRORC3,RMPROBR4
.S RMPRORC2=$P($G(^TMP("RMPRIF",$J,"ORC")),"|",2)
.S RMPRORC3=$P($G(^TMP("RMPRIF",$J,"ORC")),"|",3)
.S RMPROBR4=$P($G(^TMP("RMPRIF",$J,"OBR")),"|",4)
.I ($P(RMPRORC2,U,2)=$P(RMPRORC3,U,2)),((RMPROBR4["PROSTHETICS IFC")!(RMPROBR4["PSAS")),$$IEN^XUAF4($P(RMPRORC2,U,2))=$$KSP^XUPARAM("INST"),$D(^GMR(123,+RMPRORC3,0)) D
..N RMPRDCIN
..S RMPRDCIN="" F S RMPRDCIN=$O(^RMPR(668,"D",RMPR123A,RMPRDCIN)) Q:RMPRDCIN="" D ; ICR #7131
...D CANCEL(RMPRDCIN)
.D EXIT
;
; Strip off NPI from OBR-16. wtc 6/29/2022 p184
;
N OBR16 S OBR16=$P($G(^TMP("RMPRIF",$J,"OBR")),"|",16) I $L(OBR16,U)>2,$P(OBR16,U,1)?10N S OBR16=$P(OBR16,U,2,99),$P(^TMP("RMPRIF",$J,"OBR"),"|",16)=OBR16 ;
;
I RMPRST="NW" D EN^RMPRFC4 Q ; Use Prosthetics to file New Order
Q
;
EXIT ;common exit point
K ^TMP("RMPRIF",$J)
D EXIT^RMPRFC4
Q
;
CANCEL(DA) ;cancel suspense (EHRM)
;set status to X and cancelled by to duz, date/time.
;
N RMPRERR,RMPRDA,RMPREODT
I '$G(^RMPR(668,+$G(DA),0)) Q ; ICR #7131
I $P(^RMPR(668,DA,0),U,5)'="" Q ; ICR #7131
S RMPRDA=DA_","
D NOW^%DTC S RMPREODT=%
N FDA,RESULT
S FDA(668,RMPRDA,14)="X"
S FDA(668,RMPRDA,17)=.5
S FDA(668,RMPRDA,18)=RMPREODT
S FDA(668,RMPRDA,9)=9
D FILE^DIE("","FDA","RESULT") ; ICR #7131
L -^RMPR(668,DA)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRCRFC0 3131 printed Apr 09, 2024@20:50:48 Page 2
GMRCRFC0 ;EHRM/JCH - Process IFC HL7 Messages; Jun 30, 2022@08:17:08
+1 ;;3.0;CONSULT/REQUEST TRACKING;**154,184**;DEC 27, 1997;Build 22
+2 ;
+3 QUIT
EN(HLNEXT,HLQUIT) ;process IFC responses
+1 ;load message in ^TMP
+2 KILL ^TMP("RMPRIF",$JOB)
+3 NEW HLNODE,SEG,I
+4 NEW %,RMPR123,RMPR123A,RMPR123I,RMPRISIT,RMPRST,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 ;is it a NW or DC order?
+2 IF '$DATA(^TMP("RMPRIF",$JOB,"ORC"))
GOTO EXIT
+3 SET RMPRST=$PIECE(^TMP("RMPRIF",$JOB,"ORC"),"|",1)
+4 IF RMPRST="OD"
SET RMPRST=$PIECE(^TMP("RMPRIF",$JOB,"ORC"),"|",5)
+5 IF (RMPRST'="NW")&(RMPRST'="DC")
DO EXIT
QUIT
+6 ;
+7 IF $PIECE($GET(^TMP("RMPRIF",$JOB,"OBR")),"|",4)'["PROSTHETICS IFC"
DO EXIT
QUIT
+8 ;
+9 ;is it a discontinued order? does it have a consult ien?
+10 ;is there a local consult ien? has it already been filed in 668?
+11 IF RMPRST="NW"
Begin DoDot:1
+12 SET RMPR123=$PIECE(^TMP("RMPRIF",$JOB,"OBR"),"|",2)
+13 SET RMPR123I=$PIECE(RMPR123,U,1)
SET RMPRISIT=$PIECE(RMPR123,U,2)
End DoDot:1
+14 ;
+15 IF RMPRST="DC"
Begin DoDot:1
+16 SET RMPR123=$PIECE(^TMP("RMPRIF",$JOB,"ORC"),"|",3)
+17 SET RMPR123I=$PIECE(RMPR123,U,1)
SET RMPRISIT=$PIECE(RMPR123,U,2)
+18 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 ;When HL7 link is down possible to get mult NW msg
+9 ; ICR #7131
IF RMPRST="NW"
IF $DATA(^RMPR(668,"D",RMPR123A))
DO EXIT
QUIT
+10 SET ^TMP("RMPRIF",$JOB,"GOODTOGO")="OKAY"
+11 IF RMPRST="DC"
Begin DoDot:1
+12 NEW RMPRORC2,RMPRORC3,RMPROBR4
+13 SET RMPRORC2=$PIECE($GET(^TMP("RMPRIF",$JOB,"ORC")),"|",2)
+14 SET RMPRORC3=$PIECE($GET(^TMP("RMPRIF",$JOB,"ORC")),"|",3)
+15 SET RMPROBR4=$PIECE($GET(^TMP("RMPRIF",$JOB,"OBR")),"|",4)
+16 IF ($PIECE(RMPRORC2,U,2)=$PIECE(RMPRORC3,U,2))
IF ((RMPROBR4["PROSTHETICS IFC")!(RMPROBR4["PSAS"))
IF $$IEN^XUAF4($PIECE(RMPRORC2,U,2))=$$KSP^XUPARAM("INST")
IF $DATA(^GMR(123,+RMPRORC3,0))
Begin DoDot:2
+17 NEW RMPRDCIN
+18 ; ICR #7131
SET RMPRDCIN=""
FOR
SET RMPRDCIN=$ORDER(^RMPR(668,"D",RMPR123A,RMPRDCIN))
if RMPRDCIN=""
QUIT
Begin DoDot:3
+19 DO CANCEL(RMPRDCIN)
End DoDot:3
End DoDot:2
+20 DO EXIT
End DoDot:1
QUIT
+21 ;
+22 ; Strip off NPI from OBR-16. wtc 6/29/2022 p184
+23 ;
+24 ;
NEW OBR16
SET OBR16=$PIECE($GET(^TMP("RMPRIF",$JOB,"OBR")),"|",16)
IF $LENGTH(OBR16,U)>2
IF $PIECE(OBR16,U,1)?10N
SET OBR16=$PIECE(OBR16,U,2,99)
SET $PIECE(^TMP("RMPRIF",$JOB,"OBR"),"|",16)=OBR16
+25 ;
+26 ; Use Prosthetics to file New Order
IF RMPRST="NW"
DO EN^RMPRFC4
QUIT
+27 QUIT
+28 ;
EXIT ;common exit point
+1 KILL ^TMP("RMPRIF",$JOB)
+2 DO EXIT^RMPRFC4
+3 QUIT
+4 ;
CANCEL(DA) ;cancel suspense (EHRM)
+1 ;set status to X and cancelled by to duz, date/time.
+2 ;
+3 NEW RMPRERR,RMPRDA,RMPREODT
+4 ; ICR #7131
IF '$GET(^RMPR(668,+$GET(DA),0))
QUIT
+5 ; ICR #7131
IF $PIECE(^RMPR(668,DA,0),U,5)'=""
QUIT
+6 SET RMPRDA=DA_","
+7 DO NOW^%DTC
SET RMPREODT=%
+8 NEW FDA,RESULT
+9 SET FDA(668,RMPRDA,14)="X"
+10 SET FDA(668,RMPRDA,17)=.5
+11 SET FDA(668,RMPRDA,18)=RMPREODT
+12 SET FDA(668,RMPRDA,9)=9
+13 ; ICR #7131
DO FILE^DIE("","FDA","RESULT")
+14 LOCK -^RMPR(668,DA)
+15 QUIT
