GMRCIMSG ;SLC/JFR - IFC MESSAGE HANDLING ROUTINE; 09/26/02 00:23 ; Oct 23, 2023@07:47:54
;;3.0;CONSULT/REQUEST TRACKING;**22,28,51,44,154,184,189**;DEC 27, 1997;Build 54
;
; Reference to EN^RMPRFC3 supported by #4661
; #2053 DIE, #4838 MAGDTR01, #2165 HLMA1, #10103 XLFDT, #2263 XPAR, #2171 XUAF4, #2541 XUPARAM
; Reference to SAVEHL7^EHMHL7 supported by ICR #7424
;
Q ;don't start at the top
IN ;process incoming message and save segments to ^TMP(
K ^TMP("GMRCIF",$J)
N GMRCCRNR,GMRCMSGD,GMRCMSGI,GMRCVALM,HLNODE,SEG,I,GMRCIER ;production code ;MKN GMRC*3*154 added GMRCCRNR, GMRCMSGI, GMRCVALM
N GMRCI,TCH,TEXTIN,TEXTOUT,TEXTRM,GMRCFRM ;MKN GMRC*3*154
S GMRCCRNR=0,GMRCMSGI="" ;MKN GMRC*3*154
F I=1:1 X HLNEXT Q:HLQUIT'>0 D
. I $P(HLNODE,"|",8)="CRNR" S GMRCCRNR=1 ;MKN GMRC*3*154
. I $P(HLNODE,"|")="MSH" D
.. S GMRCMSGD=$$HL7TFM^XLFDT($P(HLNODE,"|",7),"L"),GMRCMSGD=$$FMTE^XLFDT(GMRCMSGD,"P")
.. S GMRCMSGI=$P(HLNODE,"|",10)_"^"_GMRCMSGD
. I $P(HLNODE,"|")="ORC" D
.. I $G(GMRCCRNR)=1 S ^TMP("GMRCIF",$J,"GMRCCRCR")=1,GMRCFRM=$P($P(HLNODE,"|",3),U,2),^TMP("GMRCIF",$J,"GMRCCRNR")=1_U_$P(GMRCFRM,U,1) ;WTC GMRC*3.0*184
. I $P(HLNODE,"|")="OBX" D ;multiple segs for OBX
.. ;MKN GMRC*3.0*154 start of mods
.. I $P(HLNODE,"|",3)="TX" D Q
... D SETTCH
... S TEXTIN=$E(HLNODE,5,999),TEXTRM="",TEXTOUT=""
... D DECODE^GMRCHL7E(TEXTIN,.TCH,.TEXTOUT,TEXTRM)
... S ^TMP("GMRCIF",$J,"OBX",$P(HLNODE,"|",2),$P(HLNODE,"|",5))=TEXTOUT_TEXTRM
.. ;MKN GMRC*3.0*154 end of mods
.. S ^TMP("GMRCIF",$J,"OBX",$P(HLNODE,"|",2),$P(HLNODE,"|",5))=$E(HLNODE,5,999)
. I $P(HLNODE,"|")="NTE" D ; may be multiple NTE's
.. ;MKN GMRC*3.0*154 start of mods
.. D SETTCH
.. S TEXTIN=$E(HLNODE,5,999),TEXTRM="",TEXTOUT=""
.. D DECODE^GMRCHL7E(TEXTIN,.TCH,.TEXTOUT,TEXTRM)
.. S ^TMP("GMRCIF",$J,"NTE",$P(HLNODE,"|",2))=TEXTOUT
.. ;S ^TMP("GMRCIF",$J,"NTE",$P(HLNODE,"|",2))=$E(HLNODE,5,999)
.. ;MKN GMRC*3.0*154 end of mods
. I "OBXNTE"'[$P(HLNODE,"|") D ;all other segs are single
.. S ^TMP("GMRCIF",$J,$P(HLNODE,"|"))=$E(HLNODE,5,999)
. Q
;
S GMRCVALM=$$VALMSG(^TMP("GMRCIF",$J,"ORC"),GMRCCRNR) ; MKN GMRC*3.0*154
I 'GMRCVALM,'GMRCCRNR D EX Q ;chk msg for valid cslt #'s ; MKN GMRC*3.0*154 added GMRCCRNR
I 'GMRCVALM,GMRCCRNR D MGMSG^GMRCIAC2(101,GMRCMSGI),EX Q ; send app. ACK ;MKN GMRC*3*154 added GMRCCRNR and GMRCMSGI
;
I $P(^TMP("GMRCIF",$J,"ORC"),"|")="NW" D D EX Q
. I $P(^TMP("GMRCIF",$J,"ORC"),"|",2)["TST1234" D D EX Q ;testing impl
.. D TST^GMRCIAC2($NA(^TMP("GMRCIF",$J)))
. D NW^GMRCIACT($NA(^TMP("GMRCIF",$J)))
I $P(^TMP("GMRCIF",$J,"ORC"),"|")="XO" D D EX Q
. D RESUB^GMRCIAC1($NA(^TMP("GMRCIF",$J)),GMRCCRNR,GMRCMSGI) ; MKN GMRC*3.0*154 added GMRCCRNR and GMRCMSGI
I $P(^TMP("GMRCIF",$J,"ORC"),"|")="XX" D D EX Q
. D FWD^GMRCIAC1($NA(^TMP("GMRCIF",$J)),GMRCCRNR,GMRCMSGI) ; MKN GMRC*3.0*154 added GMRCCRNR and GMRCMSGI
I $P(^TMP("GMRCIF",$J,"ORC"),"|")="RE" D D EX Q
. I $P($G(^TMP("GMRCIF",$J,"OBX",4,1)),"|",11)="D" D Q
.. D DIS^GMRCIACT($NA(^TMP("GMRCIF",$J)),GMRCCRNR,GMRCMSGI) ; dis-assoc. result ; MKN GMRC*3.0*154 added GMRCCRNR and GMRCMSGI
. I $P($P(^TMP("GMRCIF",$J,"ORC"),"|",16),U)="S" D Q
.. D SF^GMRCIAC1($NA(^TMP("GMRCIF",$J)),GMRCCRNR,GMRCMSGI) ; significant findings ; MKN GMRC*3.0*154 added GMRCCRNR and GMRCMSGI
. D COMP^GMRCIAC1($NA(^TMP("GMRCIF",$J)),GMRCCRNR,GMRCMSGI) ; MKN GMRC*3.0*154 added GMRCCRNR and GMRCMSGI
D OTHER^GMRCIACT($NA(^TMP("GMRCIF",$J)),GMRCCRNR,GMRCMSGI) ; MKN GMRC*3.0*154 added GMRCCRNR and GMRCMSGI
D EX
Q
;
EX ; clean up
;
; If from Cerner, save HL7 message in file #1609. - P189
;
I $G(GMRCCRNR) D SAVEHL7^EHMHL7("IFC","CERNER-"_$P($P($G(^TMP("GMRCIF",$J,"OBR")),"|",2),"^",2),"VISTA-"_$$STA^XUAF4($$KSP^XUPARAM("INST")),"|","^","~") ;
;
; EHRM Prosthetics
N GMRCEHRM
S GMRCEHRM=$$EHRMCHK($G(^TMP("GMRCIF",$J,"ORC")),$G(^TMP("GMRCIF",$J,"OBR")))
K ^TMP("GMRCIF",$J)
; Call EHRM Prosthetics routine - added for GMRC*3*154
I GMRCEHRM=1,$T(EN^GMRCRFC0)'="" D Q ; invoke EHRM Prosthetics if tag^routine exists and this is EHRM message. Otherwise, invoke legacy routine EN^RMPRFC3
.D EN^GMRCRFC0(HLNEXT,HLQUIT)
;
;call Prosthetics routine - added for RMPR*3*83
I $T(EN^RMPRFC3)'="" D ;invoke prosthetics code if tag^routine exists
. D EN^RMPRFC3
Q
;
EHRMCHK(ORCSEG,OBRSEG) ; Check for EHRM
N GMRCORC,GMRCORC2,GMRCORC3,GMRCORC5,GMRCSTAT,GMRCOBR4
S GMRCORC2=$P($P(ORCSEG,"|",2),"^",2) ; Placer Facility
S GMRCORC3=$P($P(ORCSEG,"|",3),"^",2) ; Filler Facility
S GMRCOBR4=$P($P(OBRSEG,"|",4),"^",2) ; Text (string) component of the Universal Identifier
S GMRCSTAT=$P(ORCSEG,"|") ; Control Code
I GMRCSTAT="OD" S GMRCSTAT=$P(ORCSEG,"|",5) ; Status
I (GMRCSTAT'="NW")&(GMRCSTAT'="DC") Q 0 ; Only process NW and DC
; EHRM Prosthetics NW requires incoming Placer Facility = Local Facility, Universal Service ID contains PROSTHETICS IFC or PSAS
I GMRCSTAT="NW" I ($$IEN^XUAF4(GMRCORC2)=$$KSP^XUPARAM("INST")),((GMRCOBR4["PROSTHETICS IFC")!(GMRCOBR4["PSAS")) Q 1
; EHRM Prosthetics DC requires incoming Placer Facility = Local Facility, Placer Facility = Filler Facility, Universal Service ID contains PROSTHETICS IFC or PSAS
I GMRCSTAT="DC" I ($$IEN^XUAF4(GMRCORC2)=$$KSP^XUPARAM("INST")),(GMRCORC2=GMRCORC3),((GMRCOBR4["PROSTHETICS IFC")!(GMRCOBR4["PSAS")) Q 1
Q 0
;
ORRIN ;process IFC responses
K ^TMP("GMRCIF",$J)
N HLNODE,SEG,I,PTACCTNO ;production code
F I=1:1 X HLNEXT Q:HLQUIT'>0 D
.S ^TMP("GMRCIF",$J,$P(HLNODE,"|"))=$E(HLNODE,5,999)
;
I $D(^TMP("GMRCIF",$J,"ORC")),$P(^("ORC"),"|")="OK" D
. N GMRCFNUM,GMRCROUT,GMRCDA,FDA
. S GMRCROUT=$$IEN^XUAF4($P($P(^TMP("GMRCIF",$J,"ORC"),"|",3),U,2))
. S GMRCDA=+$P(^TMP("GMRCIF",$J,"ORC"),"|",2)
. ;I GMRCROUT'=$P(^GMR(123,GMRCDA,0),U,23) Q
. S GMRCFNUM=+$P(^TMP("GMRCIF",$J,"ORC"),"|",3)
. S FDA(1,123,GMRCDA_",",.06)=GMRCFNUM
. ;
. ; If Cerner order, extract and save patient account number. p184
. ;
. S PTACCTNO=$P($G(^TMP("GMRCIF",$J,"PID")),"|",18) I PTACCTNO'="" S FDA(1,123,GMRCDA_",",502)=PTACCTNO ;
. ;
. D UPDATE^DIE("","FDA(1)",,"GMRCERR")
. Q
;
I $P(^TMP("GMRCIF",$J,"MSA"),"|")="AA" D
. N MSGID,MSGLOG,FDA,GMRCDA,GMRCACT,GMRCLOG
. S MSGID=$P(^TMP("GMRCIF",$J,"MSA"),"|",2)
. S MSGLOG=$O(^GMR(123.6,"AM",MSGID,0)) Q:'MSGLOG
. ;
. ; Do not delete log message for 203 error (Patient not in Cerner) until 2nd acknowledgement message is received and patient account number is filed. - wtc p189 8/21/23
. ;
. S GMRCDA=$P(^GMR(123.6,MSGLOG,0),U,4) ;
. I $$GET1^DIQ(123.6,MSGLOG,.08)=203,GMRCDA,$$GET1^DIQ(123,GMRCDA,502)="" Q ;
. ;
. S FDA(1,123.6,MSGLOG_",",.06)="@"
. S FDA(1,123.6,MSGLOG_",",.08)="@"
. D UPDATE^DIE("","FDA(1)",,"GMRCERR")
. ;S GMRCDA=$P(^GMR(123.6,MSGLOG,0),U,4) Q:'GMRCDA ; p189 8/21/23
. Q:'GMRCDA ; p189 8/21/23
. S GMRCACT=$P(^GMR(123.6,MSGLOG,0),U,5) Q:'GMRCACT
. S GMRCACT=$O(^GMR(123.6,"AC",GMRCDA,GMRCACT)) D
.. I 'GMRCACT Q
.. S GMRCLOG=$O(^GMR(123.6,"AC",GMRCDA,GMRCACT,1,0)) Q:'GMRCLOG
.. I $P(^GMR(123.6,GMRCLOG,0),U,8)<900 Q ;re-send 901 & 902 immed.
.. D TRIGR^GMRCIEVT(GMRCDA,GMRCACT)
. Q
I $P(^TMP("GMRCIF",$J,"MSA"),"|")="AR" D
. N MSGID,MSGLOG,FDA,GMRCERR,GMRCE
. S MSGID=$P(^TMP("GMRCIF",$J,"MSA"),"|",2)
. S MSGLOG=$O(^GMR(123.6,"AM",MSGID,0)) Q:'MSGLOG
. S GMRCE=$P(^TMP("GMRCIF",$J,"MSA"),"|",3)
. S FDA(1,123.6,MSGLOG_",",.08)=GMRCE
. I GMRCE=802 S FDA(1,123.6,MSGLOG_",",.06)="@"
. D UPDATE^DIE("","FDA(1)",,"GMRCERR")
. I GMRCE=901!(GMRCE=902) Q ;no alerts on these probs (yet)
. I GMRCE=201 D Q
.. I '$$GET^XPAR("SYS","GMRC IFC ALERT IMMED ON PT ERR",1) Q
.. D SNDALRT^GMRCIERR(MSGLOG,"C","IFC patient error at remote facility")
. D SNDALRT^GMRCIERR(MSGLOG,"C")
. ;
. ; If message from Cerner, save to EHRM HL7 Message file (#1609). p189
. ;
. I $P(^TMP("GMRCIF",$J,"MSH"),"|",7)="CRNR" D SAVEHL7^EHMHL7("IFC","CERNER-"_$P($P($G(^TMP("GMRCIF",$J,"OBR")),"|",2),"^",2),"VISTA-"_$$STA^XUAF4($$KSP^XUPARAM("INST")),"|","^","~") ;
;
K ^TMP("GMRCIF",$J)
I $T(ORRIN^MAGDTR01)'="" D ;invoke Imaging code if tag^routine exists
. D ORRIN^MAGDTR01
Q
;
VALMSG(GMRCORC,GMRCCRNR) ;check to make sure placer and filler # match current entr
; Input:
; GMRCORC = ORC segment from incoming HL7 msg
;
I $P(GMRCORC,"|")="NW" Q 1 ; no #'s to match on new order ; MKN GMRC*3.0*154 added GMRCCRNR
N GMRCPDA,GMRCFDA,GMRCPSIT,GMRCFSIT,GMRCROL,GMRCOK
S GMRCPDA=+$P(GMRCORC,"|",2)
S GMRCPSIT=$$IEN^XUAF4($P($P(GMRCORC,"|",2),U,2))
S GMRCFDA=+$P(GMRCORC,"|",3)
S GMRCFSIT=$$IEN^XUAF4($P($P(GMRCORC,"|",3),U,2))
I $$KSP^XUPARAM("INST")=GMRCPSIT S GMRCROL="P"
I $$KSP^XUPARAM("INST")=GMRCFSIT S GMRCROL="F"
S GMRCOK=1
I '$D(GMRCROL) S GMRCOK=0,GMRCROL="" ;bad institutions in msg
I GMRCROL="P" D
. I '$D(^GMR(123,GMRCPDA,0)) S GMRCOK=0 Q ;no such cslt #
. I $P(^GMR(123,GMRCPDA,0),U,22)'=GMRCFDA S GMRCOK=0 Q ;cslt # prob
. I $P(^GMR(123,GMRCPDA,0),U,23)'=GMRCFSIT S GMRCOK=0 Q ;routing facil.
I GMRCROL="F" D
. I '$D(^GMR(123,GMRCFDA,0)) S GMRCOK=0 Q ;no such cslt #
. I $P(^GMR(123,GMRCFDA,0),U,22)'=GMRCPDA S GMRCOK=0 Q ;cslt # prob
. I $P(^GMR(123,GMRCFDA,0),U,23)'=GMRCPSIT S GMRCOK=0 Q ;routing facil.
I 'GMRCOK D ;return a 101 error to sending site
. N GMRCRSLT
. D RESP^GMRCIUTL("AR",HL("MID"),,,101) ;build HLA(
. D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.GMRCRSLT) ;-(
Q GMRCOK
;
;MKN GMRC*3.0*154 - setting up variables required by DECODE^GMRCHL7E - see call at current line 17 above
SETTCH() ;Set up TCH array with decoding characters
N GMRCI
F GMRCI=1:1:4 S TCH($P("\E\-\R\-\S\-\T\","-",GMRCI))=$E("\~^&",GMRCI)
Q
;
SETTCH2() ;Set up TCH array with encoding characters
N GMRCI
F GMRCI=1:1:4 S TCH($E("\~^&",GMRCI))=$P("\E\-\R\-\S\-\T\","-",GMRCI)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRCIMSG 9972 printed Dec 13, 2024@01:46:04 Page 2
GMRCIMSG ;SLC/JFR - IFC MESSAGE HANDLING ROUTINE; 09/26/02 00:23 ; Oct 23, 2023@07:47:54
+1 ;;3.0;CONSULT/REQUEST TRACKING;**22,28,51,44,154,184,189**;DEC 27, 1997;Build 54
+2 ;
+3 ; Reference to EN^RMPRFC3 supported by #4661
+4 ; #2053 DIE, #4838 MAGDTR01, #2165 HLMA1, #10103 XLFDT, #2263 XPAR, #2171 XUAF4, #2541 XUPARAM
+5 ; Reference to SAVEHL7^EHMHL7 supported by ICR #7424
+6 ;
+7 ;don't start at the top
QUIT
IN ;process incoming message and save segments to ^TMP(
+1 KILL ^TMP("GMRCIF",$JOB)
+2 ;production code ;MKN GMRC*3*154 added GMRCCRNR, GMRCMSGI, GMRCVALM
NEW GMRCCRNR,GMRCMSGD,GMRCMSGI,GMRCVALM,HLNODE,SEG,I,GMRCIER
+3 ;MKN GMRC*3*154
NEW GMRCI,TCH,TEXTIN,TEXTOUT,TEXTRM,GMRCFRM
+4 ;MKN GMRC*3*154
SET GMRCCRNR=0
SET GMRCMSGI=""
+5 FOR I=1:1
XECUTE HLNEXT
if HLQUIT'>0
QUIT
Begin DoDot:1
+6 ;MKN GMRC*3*154
IF $PIECE(HLNODE,"|",8)="CRNR"
SET GMRCCRNR=1
+7 IF $PIECE(HLNODE,"|")="MSH"
Begin DoDot:2
+8 SET GMRCMSGD=$$HL7TFM^XLFDT($PIECE(HLNODE,"|",7),"L")
SET GMRCMSGD=$$FMTE^XLFDT(GMRCMSGD,"P")
+9 SET GMRCMSGI=$PIECE(HLNODE,"|",10)_"^"_GMRCMSGD
End DoDot:2
+10 IF $PIECE(HLNODE,"|")="ORC"
Begin DoDot:2
+11 ;WTC GMRC*3.0*184
IF $GET(GMRCCRNR)=1
SET ^TMP("GMRCIF",$JOB,"GMRCCRCR")=1
SET GMRCFRM=$PIECE($PIECE(HLNODE,"|",3),U,2)
SET ^TMP("GMRCIF",$JOB,"GMRCCRNR")=1_U_$PIECE(GMRCFRM,U,1)
End DoDot:2
+12 ;multiple segs for OBX
IF $PIECE(HLNODE,"|")="OBX"
Begin DoDot:2
+13 ;MKN GMRC*3.0*154 start of mods
+14 IF $PIECE(HLNODE,"|",3)="TX"
Begin DoDot:3
+15 DO SETTCH
+16 SET TEXTIN=$EXTRACT(HLNODE,5,999)
SET TEXTRM=""
SET TEXTOUT=""
+17 DO DECODE^GMRCHL7E(TEXTIN,.TCH,.TEXTOUT,TEXTRM)
+18 SET ^TMP("GMRCIF",$JOB,"OBX",$PIECE(HLNODE,"|",2),$PIECE(HLNODE,"|",5))=TEXTOUT_TEXTRM
End DoDot:3
QUIT
+19 ;MKN GMRC*3.0*154 end of mods
+20 SET ^TMP("GMRCIF",$JOB,"OBX",$PIECE(HLNODE,"|",2),$PIECE(HLNODE,"|",5))=$EXTRACT(HLNODE,5,999)
End DoDot:2
+21 ; may be multiple NTE's
IF $PIECE(HLNODE,"|")="NTE"
Begin DoDot:2
+22 ;MKN GMRC*3.0*154 start of mods
+23 DO SETTCH
+24 SET TEXTIN=$EXTRACT(HLNODE,5,999)
SET TEXTRM=""
SET TEXTOUT=""
+25 DO DECODE^GMRCHL7E(TEXTIN,.TCH,.TEXTOUT,TEXTRM)
+26 SET ^TMP("GMRCIF",$JOB,"NTE",$PIECE(HLNODE,"|",2))=TEXTOUT
+27 ;S ^TMP("GMRCIF",$J,"NTE",$P(HLNODE,"|",2))=$E(HLNODE,5,999)
+28 ;MKN GMRC*3.0*154 end of mods
End DoDot:2
+29 ;all other segs are single
IF "OBXNTE"'[$PIECE(HLNODE,"|")
Begin DoDot:2
+30 SET ^TMP("GMRCIF",$JOB,$PIECE(HLNODE,"|"))=$EXTRACT(HLNODE,5,999)
End DoDot:2
+31 QUIT
End DoDot:1
+32 ;
+33 ; MKN GMRC*3.0*154
SET GMRCVALM=$$VALMSG(^TMP("GMRCIF",$JOB,"ORC"),GMRCCRNR)
+34 ;chk msg for valid cslt #'s ; MKN GMRC*3.0*154 added GMRCCRNR
IF 'GMRCVALM
IF 'GMRCCRNR
DO EX
QUIT
+35 ; send app. ACK ;MKN GMRC*3*154 added GMRCCRNR and GMRCMSGI
IF 'GMRCVALM
IF GMRCCRNR
DO MGMSG^GMRCIAC2(101,GMRCMSGI)
DO EX
QUIT
+36 ;
+37 IF $PIECE(^TMP("GMRCIF",$JOB,"ORC"),"|")="NW"
Begin DoDot:1
+38 ;testing impl
IF $PIECE(^TMP("GMRCIF",$JOB,"ORC"),"|",2)["TST1234"
Begin DoDot:2
+39 DO TST^GMRCIAC2($NAME(^TMP("GMRCIF",$JOB)))
End DoDot:2
DO EX
QUIT
+40 DO NW^GMRCIACT($NAME(^TMP("GMRCIF",$JOB)))
End DoDot:1
DO EX
QUIT
+41 IF $PIECE(^TMP("GMRCIF",$JOB,"ORC"),"|")="XO"
Begin DoDot:1
+42 ; MKN GMRC*3.0*154 added GMRCCRNR and GMRCMSGI
DO RESUB^GMRCIAC1($NAME(^TMP("GMRCIF",$JOB)),GMRCCRNR,GMRCMSGI)
End DoDot:1
DO EX
QUIT
+43 IF $PIECE(^TMP("GMRCIF",$JOB,"ORC"),"|")="XX"
Begin DoDot:1
+44 ; MKN GMRC*3.0*154 added GMRCCRNR and GMRCMSGI
DO FWD^GMRCIAC1($NAME(^TMP("GMRCIF",$JOB)),GMRCCRNR,GMRCMSGI)
End DoDot:1
DO EX
QUIT
+45 IF $PIECE(^TMP("GMRCIF",$JOB,"ORC"),"|")="RE"
Begin DoDot:1
+46 IF $PIECE($GET(^TMP("GMRCIF",$JOB,"OBX",4,1)),"|",11)="D"
Begin DoDot:2
+47 ; dis-assoc. result ; MKN GMRC*3.0*154 added GMRCCRNR and GMRCMSGI
DO DIS^GMRCIACT($NAME(^TMP("GMRCIF",$JOB)),GMRCCRNR,GMRCMSGI)
End DoDot:2
QUIT
+48 IF $PIECE($PIECE(^TMP("GMRCIF",$JOB,"ORC"),"|",16),U)="S"
Begin DoDot:2
+49 ; significant findings ; MKN GMRC*3.0*154 added GMRCCRNR and GMRCMSGI
DO SF^GMRCIAC1($NAME(^TMP("GMRCIF",$JOB)),GMRCCRNR,GMRCMSGI)
End DoDot:2
QUIT
+50 ; MKN GMRC*3.0*154 added GMRCCRNR and GMRCMSGI
DO COMP^GMRCIAC1($NAME(^TMP("GMRCIF",$JOB)),GMRCCRNR,GMRCMSGI)
End DoDot:1
DO EX
QUIT
+51 ; MKN GMRC*3.0*154 added GMRCCRNR and GMRCMSGI
DO OTHER^GMRCIACT($NAME(^TMP("GMRCIF",$JOB)),GMRCCRNR,GMRCMSGI)
+52 DO EX
+53 QUIT
+54 ;
EX ; clean up
+1 ;
+2 ; If from Cerner, save HL7 message in file #1609. - P189
+3 ;
+4 ;
IF $GET(GMRCCRNR)
DO SAVEHL7^EHMHL7("IFC","CERNER-"_$PIECE($PIECE($GET(^TMP("GMRCIF",$JOB,"OBR")),"|",2),"^",2),"VISTA-"_$$STA^XUAF4($$KSP^XUPARAM("INST")),"|","^","~")
+5 ;
+6 ; EHRM Prosthetics
+7 NEW GMRCEHRM
+8 SET GMRCEHRM=$$EHRMCHK($GET(^TMP("GMRCIF",$JOB,"ORC")),$GET(^TMP("GMRCIF",$JOB,"OBR")))
+9 KILL ^TMP("GMRCIF",$JOB)
+10 ; Call EHRM Prosthetics routine - added for GMRC*3*154
+11 ; invoke EHRM Prosthetics if tag^routine exists and this is EHRM message. Otherwise, invoke legacy routine EN^RMPRFC3
IF GMRCEHRM=1
IF $TEXT(EN^GMRCRFC0)'=""
Begin DoDot:1
+12 DO EN^GMRCRFC0(HLNEXT,HLQUIT)
End DoDot:1
QUIT
+13 ;
+14 ;call Prosthetics routine - added for RMPR*3*83
+15 ;invoke prosthetics code if tag^routine exists
IF $TEXT(EN^RMPRFC3)'=""
Begin DoDot:1
+16 DO EN^RMPRFC3
End DoDot:1
+17 QUIT
+18 ;
EHRMCHK(ORCSEG,OBRSEG) ; Check for EHRM
+1 NEW GMRCORC,GMRCORC2,GMRCORC3,GMRCORC5,GMRCSTAT,GMRCOBR4
+2 ; Placer Facility
SET GMRCORC2=$PIECE($PIECE(ORCSEG,"|",2),"^",2)
+3 ; Filler Facility
SET GMRCORC3=$PIECE($PIECE(ORCSEG,"|",3),"^",2)
+4 ; Text (string) component of the Universal Identifier
SET GMRCOBR4=$PIECE($PIECE(OBRSEG,"|",4),"^",2)
+5 ; Control Code
SET GMRCSTAT=$PIECE(ORCSEG,"|")
+6 ; Status
IF GMRCSTAT="OD"
SET GMRCSTAT=$PIECE(ORCSEG,"|",5)
+7 ; Only process NW and DC
IF (GMRCSTAT'="NW")&(GMRCSTAT'="DC")
QUIT 0
+8 ; EHRM Prosthetics NW requires incoming Placer Facility = Local Facility, Universal Service ID contains PROSTHETICS IFC or PSAS
+9 IF GMRCSTAT="NW"
IF ($$IEN^XUAF4(GMRCORC2)=$$KSP^XUPARAM("INST"))
IF ((GMRCOBR4["PROSTHETICS IFC")!(GMRCOBR4["PSAS"))
QUIT 1
+10 ; EHRM Prosthetics DC requires incoming Placer Facility = Local Facility, Placer Facility = Filler Facility, Universal Service ID contains PROSTHETICS IFC or PSAS
+11 IF GMRCSTAT="DC"
IF ($$IEN^XUAF4(GMRCORC2)=$$KSP^XUPARAM("INST"))
IF (GMRCORC2=GMRCORC3)
IF ((GMRCOBR4["PROSTHETICS IFC")!(GMRCOBR4["PSAS"))
QUIT 1
+12 QUIT 0
+13 ;
ORRIN ;process IFC responses
+1 KILL ^TMP("GMRCIF",$JOB)
+2 ;production code
NEW HLNODE,SEG,I,PTACCTNO
+3 FOR I=1:1
XECUTE HLNEXT
if HLQUIT'>0
QUIT
Begin DoDot:1
+4 SET ^TMP("GMRCIF",$JOB,$PIECE(HLNODE,"|"))=$EXTRACT(HLNODE,5,999)
End DoDot:1
+5 ;
+6 IF $DATA(^TMP("GMRCIF",$JOB,"ORC"))
IF $PIECE(^("ORC"),"|")="OK"
Begin DoDot:1
+7 NEW GMRCFNUM,GMRCROUT,GMRCDA,FDA
+8 SET GMRCROUT=$$IEN^XUAF4($PIECE($PIECE(^TMP("GMRCIF",$JOB,"ORC"),"|",3),U,2))
+9 SET GMRCDA=+$PIECE(^TMP("GMRCIF",$JOB,"ORC"),"|",2)
+10 ;I GMRCROUT'=$P(^GMR(123,GMRCDA,0),U,23) Q
+11 SET GMRCFNUM=+$PIECE(^TMP("GMRCIF",$JOB,"ORC"),"|",3)
+12 SET FDA(1,123,GMRCDA_",",.06)=GMRCFNUM
+13 ;
+14 ; If Cerner order, extract and save patient account number. p184
+15 ;
+16 ;
SET PTACCTNO=$PIECE($GET(^TMP("GMRCIF",$JOB,"PID")),"|",18)
IF PTACCTNO'=""
SET FDA(1,123,GMRCDA_",",502)=PTACCTNO
+17 ;
+18 DO UPDATE^DIE("","FDA(1)",,"GMRCERR")
+19 QUIT
End DoDot:1
+20 ;
+21 IF $PIECE(^TMP("GMRCIF",$JOB,"MSA"),"|")="AA"
Begin DoDot:1
+22 NEW MSGID,MSGLOG,FDA,GMRCDA,GMRCACT,GMRCLOG
+23 SET MSGID=$PIECE(^TMP("GMRCIF",$JOB,"MSA"),"|",2)
+24 SET MSGLOG=$ORDER(^GMR(123.6,"AM",MSGID,0))
if 'MSGLOG
QUIT
+25 ;
+26 ; Do not delete log message for 203 error (Patient not in Cerner) until 2nd acknowledgement message is received and patient account number is filed. - wtc p189 8/21/23
+27 ;
+28 ;
SET GMRCDA=$PIECE(^GMR(123.6,MSGLOG,0),U,4)
+29 ;
IF $$GET1^DIQ(123.6,MSGLOG,.08)=203
IF GMRCDA
IF $$GET1^DIQ(123,GMRCDA,502)=""
QUIT
+30 ;
+31 SET FDA(1,123.6,MSGLOG_",",.06)="@"
+32 SET FDA(1,123.6,MSGLOG_",",.08)="@"
+33 DO UPDATE^DIE("","FDA(1)",,"GMRCERR")
+34 ;S GMRCDA=$P(^GMR(123.6,MSGLOG,0),U,4) Q:'GMRCDA ; p189 8/21/23
+35 ; p189 8/21/23
if 'GMRCDA
QUIT
+36 SET GMRCACT=$PIECE(^GMR(123.6,MSGLOG,0),U,5)
if 'GMRCACT
QUIT
+37 SET GMRCACT=$ORDER(^GMR(123.6,"AC",GMRCDA,GMRCACT))
Begin DoDot:2
+38 IF 'GMRCACT
QUIT
+39 SET GMRCLOG=$ORDER(^GMR(123.6,"AC",GMRCDA,GMRCACT,1,0))
if 'GMRCLOG
QUIT
+40 ;re-send 901 & 902 immed.
IF $PIECE(^GMR(123.6,GMRCLOG,0),U,8)<900
QUIT
+41 DO TRIGR^GMRCIEVT(GMRCDA,GMRCACT)
End DoDot:2
+42 QUIT
End DoDot:1
+43 IF $PIECE(^TMP("GMRCIF",$JOB,"MSA"),"|")="AR"
Begin DoDot:1
+44 NEW MSGID,MSGLOG,FDA,GMRCERR,GMRCE
+45 SET MSGID=$PIECE(^TMP("GMRCIF",$JOB,"MSA"),"|",2)
+46 SET MSGLOG=$ORDER(^GMR(123.6,"AM",MSGID,0))
if 'MSGLOG
QUIT
+47 SET GMRCE=$PIECE(^TMP("GMRCIF",$JOB,"MSA"),"|",3)
+48 SET FDA(1,123.6,MSGLOG_",",.08)=GMRCE
+49 IF GMRCE=802
SET FDA(1,123.6,MSGLOG_",",.06)="@"
+50 DO UPDATE^DIE("","FDA(1)",,"GMRCERR")
+51 ;no alerts on these probs (yet)
IF GMRCE=901!(GMRCE=902)
QUIT
+52 IF GMRCE=201
Begin DoDot:2
+53 IF '$$GET^XPAR("SYS","GMRC IFC ALERT IMMED ON PT ERR",1)
QUIT
+54 DO SNDALRT^GMRCIERR(MSGLOG,"C","IFC patient error at remote facility")
End DoDot:2
QUIT
+55 DO SNDALRT^GMRCIERR(MSGLOG,"C")
+56 ;
+57 ; If message from Cerner, save to EHRM HL7 Message file (#1609). p189
+58 ;
+59 ;
IF $PIECE(^TMP("GMRCIF",$JOB,"MSH"),"|",7)="CRNR"
DO SAVEHL7^EHMHL7("IFC","CERNER-"_$PIECE($PIECE($GET(^TMP("GMRCIF",$JOB,"OBR")),"|",2),"^",2),"VISTA-"_$$STA^XUAF4($$KSP^XUPARAM("INST")),"|","^","~")
End DoDot:1
+60 ;
+61 KILL ^TMP("GMRCIF",$JOB)
+62 ;invoke Imaging code if tag^routine exists
IF $TEXT(ORRIN^MAGDTR01)'=""
Begin DoDot:1
+63 DO ORRIN^MAGDTR01
End DoDot:1
+64 QUIT
+65 ;
VALMSG(GMRCORC,GMRCCRNR) ;check to make sure placer and filler # match current entr
+1 ; Input:
+2 ; GMRCORC = ORC segment from incoming HL7 msg
+3 ;
+4 ; no #'s to match on new order ; MKN GMRC*3.0*154 added GMRCCRNR
IF $PIECE(GMRCORC,"|")="NW"
QUIT 1
+5 NEW GMRCPDA,GMRCFDA,GMRCPSIT,GMRCFSIT,GMRCROL,GMRCOK
+6 SET GMRCPDA=+$PIECE(GMRCORC,"|",2)
+7 SET GMRCPSIT=$$IEN^XUAF4($PIECE($PIECE(GMRCORC,"|",2),U,2))
+8 SET GMRCFDA=+$PIECE(GMRCORC,"|",3)
+9 SET GMRCFSIT=$$IEN^XUAF4($PIECE($PIECE(GMRCORC,"|",3),U,2))
+10 IF $$KSP^XUPARAM("INST")=GMRCPSIT
SET GMRCROL="P"
+11 IF $$KSP^XUPARAM("INST")=GMRCFSIT
SET GMRCROL="F"
+12 SET GMRCOK=1
+13 ;bad institutions in msg
IF '$DATA(GMRCROL)
SET GMRCOK=0
SET GMRCROL=""
+14 IF GMRCROL="P"
Begin DoDot:1
+15 ;no such cslt #
IF '$DATA(^GMR(123,GMRCPDA,0))
SET GMRCOK=0
QUIT
+16 ;cslt # prob
IF $PIECE(^GMR(123,GMRCPDA,0),U,22)'=GMRCFDA
SET GMRCOK=0
QUIT
+17 ;routing facil.
IF $PIECE(^GMR(123,GMRCPDA,0),U,23)'=GMRCFSIT
SET GMRCOK=0
QUIT
End DoDot:1
+18 IF GMRCROL="F"
Begin DoDot:1
+19 ;no such cslt #
IF '$DATA(^GMR(123,GMRCFDA,0))
SET GMRCOK=0
QUIT
+20 ;cslt # prob
IF $PIECE(^GMR(123,GMRCFDA,0),U,22)'=GMRCPDA
SET GMRCOK=0
QUIT
+21 ;routing facil.
IF $PIECE(^GMR(123,GMRCFDA,0),U,23)'=GMRCPSIT
SET GMRCOK=0
QUIT
End DoDot:1
+22 ;return a 101 error to sending site
IF 'GMRCOK
Begin DoDot:1
+23 NEW GMRCRSLT
+24 ;build HLA(
DO RESP^GMRCIUTL("AR",HL("MID"),,,101)
+25 ;-(
DO GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.GMRCRSLT)
End DoDot:1
+26 QUIT GMRCOK
+27 ;
+28 ;MKN GMRC*3.0*154 - setting up variables required by DECODE^GMRCHL7E - see call at current line 17 above
SETTCH() ;Set up TCH array with decoding characters
+1 NEW GMRCI
+2 FOR GMRCI=1:1:4
SET TCH($PIECE("\E\-\R\-\S\-\T\","-",GMRCI))=$EXTRACT("\~^&",GMRCI)
+3 QUIT
+4 ;
SETTCH2() ;Set up TCH array with encoding characters
+1 NEW GMRCI
+2 FOR GMRCI=1:1:4
SET TCH($EXTRACT("\~^&",GMRCI))=$PIECE("\E\-\R\-\S\-\T\","-",GMRCI)
+3 QUIT
+4 ;
