- 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 Apr 23, 2025@18:00:31 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 ;
