GMRCIEVT ;SLC/JFR - process events and build HL7 message; 6/20/2021 09:23 ; Aug 12, 2024@09:30:42
;;3.0;CONSULT/REQUEST TRACKING;**22,28,31,121,154,184,189**;DEC 27, 1997;Build 54
;;Per VHA Directive 2004-038, this routine should not be modified.
; #7133 GETPAT MPIFRES, #7134 GETICN MPIFXMLI, #2161 HFLNC2, #2164 HLMA, #2271 HLUTIL3, #2701 MPIF001, #3015 VAFCPID, #4648 VAFCTFU2, #10112 VASITE
; #2053 DIE, #2056 DIQ, #2171 XUAF4, #2263 XPAR
; Reference to $$ADD^DGPROSAD in ICR #7421
; Reference to $$CRNRSITE^VAFCCRNR in ICR #7346
;
Q ;don't start at the top
TRIGR(IEN,ACTN) ;determine what action was taken on IFC and call event point
;Input:
; IEN = consult number from file 123
; ACT = ien in 40 multiple corresponding to activity
;
;CLT, GMRC*3.0*184, Do not send a msg back on receipt of a comment from
; cerner. That causes a duplicate entry at cerner.
N GMRCDQ,GMRCDQ1 S GMRCDQ=0
S GMRCDQ1=$$NOSND^GMRCIUTL() I GMRCDQ1=1 Q
N ACTYPE
S ACTYPE=$P(^GMR(123,IEN,40,ACTN,0),U,2)
I 'ACTYPE Q
I ACTYPE=26 Q ;don't send admin corrections yet...
;
; check bkgrd job and run if overdue
I '$D(ZTQUEUED),$$GONOGO^GMRCIBKG D
. N ZTQUEUED S ZTQUEUED=1 D EN^GMRCIBKG ;remove ZTQUEUED?
;
I $O(^GMR(123.6,"AC",IEN,ACTN),-1) D Q ;earlier pending activities
. I ACTYPE=22 Q ; not a trigger or not done here
. I ACTYPE=6 N GMRCQT D I $D(GMRCQT) Q
.. ;complete all transactions if IFC DC'd before request ever sent
.. I $O(^GMR(123.6,"AC",IEN,ACTN),-1)'=1 Q ;new request already sent
.. S GMRCQT=1
.. N DA,DIE,DR,GMRCACTS
.. S GMRCACTS=0
.. F S GMRCACTS=$O(^GMR(123.6,"AC",IEN,GMRCACTS)) Q:'GMRCACTS D
... S DIE="^GMR(123.6,",DA=$O(^GMR(123.6,"AC",IEN,GMRCACTS,1,0))
... S DR=".06///@" D ^DIE
. D LOGMSG^GMRCIUTL(IEN,ACTN,"",902) ;msg log entry but no msg sent
I ACTYPE=2!(ACTYPE=1) D NW(IEN,ACTN) Q ;send new order - Added ACTN as parameter. P189 WTC 6/24/2024
I ACTYPE=9!(ACTYPE=14) D RSLT(IEN,ACTN) Q ;inc report or add'l notes
I ACTYPE=10,$P(^GMR(123,IEN,40,ACTN,0),U,9) D RSLT(IEN,ACTN) Q ;comp
I ACTYPE=12 D RSLT(IEN,ACTN) Q ;dis-associate result
I ACTYPE=11 D RESUB^GMRCIEV1(IEN,ACTN) Q ;ed/resubmit
I ACTYPE=13 D RSLT(IEN,ACTN) Q ; addendum added
I ACTYPE=4 D SF^GMRCIEV1(IEN,ACTN) Q ; sig finding update
I ACTYPE=22 Q ;printed to is not a trigger
I ACTYPE=17 D FWD^GMRCIEV1(IEN,ACTN) Q ; forward
I ACTYPE=25 D FWD2IFC^GMRCIEV1(IEN,ACTN) Q ; FWD into an IFC service
D GENUPD(IEN,ACTN) ;all other updates
Q
NW(GMRCDA,ACTN) ;build new order message for IFC
; Input:
; GMRCDA = ien from file 123
;
N HL,HLL,SEG,GMRC773,GMRCIQT,GMRCPD,PROXYADD,GMRCDFN,STA,SITE ;
;
S PROXYADD=$$CHKCORR(GMRCDA) Q:'PROXYADD ;MKN GMRC*3.0*154 Check PT correlation and do proxy add if required, changed to function p189 wtc 12/5/23
S SEG=1
K ^TMP("HLS",$J)
D INIT^HLFNC2("GMRC IFC ORM EVENT",.HL)
I $G(HL) D Q ; if HL array can't be built, log it with an error
. D LOGMSG^GMRCIUTL(GMRCDA,ACTN,,904) ;MKN GMRC*3.0*154 GMRCACT to ACTN
D I $D(GMRCIQT) D NOMPI(GMRCDA,1) Q ;build PID seg if not a local ICN
. S GMRCDFN=$P(^GMR(123,+GMRCDA,0),U,2)
. I '$G(GMRCDFN) S GMRCIQT=1 Q
. I $$GETICN^MPIF001(GMRCDFN)<1 S GMRCIQT=1 Q
. I $$IFLOCAL^MPIF001(GMRCDFN) S GMRCIQT=1 Q
. S ^TMP("HLS",$J,SEG)=$$EN^VAFCPID(GMRCDFN,"1,2,3,4,5,7,8,19")
. ;
. ; If remote site is converted, enhance the PID segment. p184
. ;
. I $$CNVTD(GMRCDA)=1 S ^TMP("HLS",$J,SEG)=$$ADD2PID^GMRCIUTL(^TMP("HLS",$J,SEG),GMRCDFN,$P($G(^GMR(123,GMRCDA,"CERNER")),U,3)) ;
. ;
. S SEG=SEG+1
. Q
S ^TMP("HLS",$J,SEG)=$$NWORC^GMRCISG1(GMRCDA) ; get ORC for new ord
S SEG=SEG+1
S ^TMP("HLS",$J,SEG)=$$OBR^GMRCISG1(GMRCDA) ;get OBR segment
;
; If remote site is converted, enhance the OBR segment. p184
;
I $$CNVTD(GMRCDA)=1 S ^TMP("HLS",$J,SEG)=$$ADD2OBR^GMRCIUTL(^TMP("HLS",$J,SEG),GMRCDA) ;
;
S SEG=SEG+1
D ;build reason for request into OBX segment(s)
. K ^TMP("GMRCRFR",$J)
. D OBXWP^GMRCISEG(GMRCDA,"NW",1,$NA(^TMP("GMRCRFR",$J)))
. I '$D(^TMP("GMRCRFR",$J)) Q
. N I S I=0
. F S I=$O(^TMP("GMRCRFR",$J,I)) Q:'I D
.. S ^TMP("HLS",$J,SEG)=^TMP("GMRCRFR",$J,I)
.. S SEG=SEG+1
. K ^TMP("GMRCRFR",$J)
. Q
S GMRCPD=$$OBXPD^GMRCISG1(GMRCDA) ;bl;154 preventing blank line for OBX
I GMRCPD'="" S ^TMP("HLS",$J,SEG)=GMRCPD ; build prov DX in OBX
S SEG=SEG+1
S ^TMP("HLS",$J,SEG)=$$OBXTZ^GMRCISEG ;always send local time zone
;
;AV/MKN Add NTE segment to HL7 to send UCID file #123, field #80 *121*
N SEP
S SEP=HL("FS")
N UCID S UCID=$$GET1^DIQ(123,GMRCDA,80) S:UCID]"" SEG=SEG+1,^TMP("HLS",$J,SEG)="NTE"_SEP_"P"_SEP_"UCID:"_UCID
;AV/MKN End of NTE for UCID *121*
;
S SITE=$P(^GMR(123,GMRCDA,0),U,23) I 'SITE D LOGMSG^GMRCIUTL(IEN,ACTN,"",903) Q ;no ROUTING FACILITY
S STA=$$STA^XUAF4(SITE) I '$L(STA) D LOGMSG^GMRCIUTL(IEN,ACTN,"",903) Q ;can't find station num for that site
;
; If patient just proxy added, generate error 205 if not completed yet. p189 wtc 6/18/2024
;
I $P(PROXYADD,U,2)="ADDED",+$$CHKPROXY^GMRCIUT1(GMRCDA,GMRCDFN,STA)=0 D LOGMSG^GMRCIUTL(IEN,ACTN,"",205) Q ;
;
; Otherwise, set route according to whether destination site is converted (use $$GET^XPAR("SYS","GMRC IFC REGIONAL ROUTER",1)) or non-converted (use D LINK^HLUTIL3(STA,.GMRCLINK,"I"))
;
S HLL("LINKS",1)=$$ROUTE(GMRCDA) I '$L(HLL("LINKS",1)) D Q ;log error
. D:'$$EXIST201^GMRCIEV1(GMRCDA,GMRCACT) LOGMSG^GMRCIUTL(GMRCDA,GMRCACT,"",903) ;MKN GMRC*3*154 '$$EXIST201
S HLP("SUBSCRIBER")="^^^^"_$P(HLL("LINKS",1),U,3) ;MKN GMRC*3*154 Station coming back from $$ROUTE
D GENERATE^HLMA("GMRC IFC ORM EVENT","GM",1,.GMRC773,,.HLP) ;MKN GMRC*3*154 added 6th parameter that passes to HLP array in GENERATE^HLMA
N ERR S ERR=$S($P(GMRC773,U,2):904,1:"")
;
D LOGMSG^GMRCIUTL(GMRCDA,1,+GMRC773,ERR)
Q
;
GENUPD(GMRCDA,GMRCACT) ;build msg and send upon REC, SC or ADD CMT event
N HL,HLL,SEG,GMRC773,GMRCCRNR,GMRCIQT,OBR,PROSTHCS ; P184
N EDIPI,ICN,PTACCTNO,FS,CS,REPTTN S PTACCTNO=$P($G(^GMR(123,GMRCDA,"CERNER")),U,3) ; p184
S SEG=1
K ^TMP("HLS",$J)
D INIT^HLFNC2("GMRC IFC ORM EVENT",.HL)
I $G(HL) D Q ; if HL array can't be built, log it with an error
. D LOGMSG^GMRCIUTL(GMRCDA,GMRCACT,,904)
D I $D(GMRCIQT) D NOMPI(GMRCDA,GMRCACT) Q ;build PID seg if nat'l ICN
. N GMRCDFN S GMRCDFN=$P(^GMR(123,+GMRCDA,0),U,2)
. I '$G(GMRCDFN) S GMRCIQT=1 Q
. I $$GETICN^MPIF001(GMRCDFN)<1 S GMRCIQT=1 Q
. I $$IFLOCAL^MPIF001(GMRCDFN) S GMRCIQT=1 Q
. S ^TMP("HLS",$J,SEG)=$$EN^VAFCPID(GMRCDFN,"1,2,3,4,5,7,8,19")
. ;
. ; If remote site is converted, enhance the PID segment. p184
. ;
. I $$CNVTD(GMRCDA)=1 S ^TMP("HLS",$J,SEG)=$$ADD2PID^GMRCIUTL(^TMP("HLS",$J,SEG),GMRCDFN,PTACCTNO) ;
. S SEG=SEG+1 ;
. Q
D ;build ORC seg based on GMRCACT
. N ACTVT,OC,OS
. S ACTVT=$P(^GMR(123,GMRCDA,40,GMRCACT,0),U,2) ; get activity
. ;set order control for ORC seg:
. ; v-- IP=cmt RE=adm comp OD=DC OC=cancel SC=sch or receive
. S OC=$S(ACTVT=20:"IP",ACTVT=10:"RE",ACTVT=6:"OD",ACTVT=19:"OC",1:"SC")
. ;set order status for ORC seg:
. ; v-- SC=sch RE=adm comp DC=DC CA=cancel IP=cmt or receive
. S OS=$S(ACTVT=8:"SC",ACTVT=10:"CM",ACTVT=6:"DC",ACTVT=19:"CA",1:"IP")
. S ^TMP("HLS",$J,SEG)=$$ORC^GMRCISEG(GMRCDA,OC,OS,GMRCACT)
. S SEG=SEG+1
. Q
;
; Generate OBR segment if IFC is from converted site. p184
;
I $$CNVTD(GMRCDA)=1 D ;
. ;
. S OBR=$$OBR^GMRCISG1(GMRCDA) ;
. S OBR=$$ADD2OBR^GMRCIUTL(OBR,GMRCDA) ;
. S ^TMP("HLS",$J,SEG)=OBR ;
. S SEG=SEG+1 ;
;
; Determine if order is for Prosthetics - p184 WTC 6/1/22
;
S PROSTHCS=$S($G(OBR)="":0,$P($P(OBR,"|",5),U,2)["PROSTHETICS IFC":1,1:0) ; P184
;
I $L($P(^GMR(123,GMRCDA,0),U,19)) D ;send sig findings
. S ^TMP("HLS",$J,SEG)=$$OBXSF^GMRCISEG(GMRCDA)
. S SEG=SEG+1
I $O(^GMR(123,GMRCDA,40,GMRCACT,1,0)) D ;load up a comment if there
. N I
. K ^TMP("GMRCMT",$J)
. S GMRCCRNR=$$ISCERNER(GMRCDA) ;MKN 184
. I $P(^TMP("HLS",$J,SEG-1),"|",2)'["O" D
.. D:GMRCCRNR&'PROSTHCS CRNROBX^GMRCIEV1(GMRCDA,$NA(^TMP("GMRCMT",$J))) ; p184 - wtc 6/1/22
.. D:'GMRCCRNR!PROSTHCS OBXWP^GMRCISEG(GMRCDA,"",GMRCACT,$NA(^TMP("GMRCMT",$J))) ; p184 - wtc 6/1/22
. I $P(^TMP("HLS",$J,SEG-1),"|",2)["O" D
.. I GMRCCRNR,'PROSTHCS D CRNRNTE^GMRCIEV1(GMRCDA,$NA(^TMP("GMRCMT",$J))) ; p184 - wtc 6/1/22
.. I 'GMRCCRNR!PROSTHCS N GMRCMT D NTE^GMRCISEG(GMRCDA,GMRCACT,.GMRCMT) I $D(GMRCMT) M ^TMP("GMRCMT",$J)=GMRCMT ; p184 - wtc 6/1/22
. Q:'$O(^TMP("GMRCMT",$J,0))
. S I=0 F S I=$O(^TMP("GMRCMT",$J,I)) Q:'I D
.. S ^TMP("HLS",$J,SEG)=^TMP("GMRCMT",$J,I)
.. S SEG=SEG+1
. K ^TMP("GMRCMT",$J)
. Q
S ^TMP("HLS",$J,SEG)=$$OBXTZ^GMRCISEG ;always include local time zone
S HLL("LINKS",1)=$$ROUTE(GMRCDA) I '$L(HLL("LINKS",1)) D Q ;log error
. D:'$$EXIST201^GMRCIEV1(GMRCDA,GMRCACT) LOGMSG^GMRCIUTL(GMRCDA,GMRCACT,"",903) ;MKN GMRC*3*154 '$$EXIST201
S HLP("SUBSCRIBER")="^^^^"_$P(HLL("LINKS",1),U,3) ;MKN GMRC*3*154 Station coming back from $$ROUTE
;
D GENERATE^HLMA("GMRC IFC ORM EVENT","GM",1,.GMRC773,,.HLP) ;MKN GMRC*3*154 added 6th parameter that passes to HLP array in GENERATE^HLMA
N ERR S ERR=$S($P(GMRC773,U,2):904,1:"") ; if err from HL7, log it
D LOGMSG^GMRCIUTL(GMRCDA,GMRCACT,+GMRC773,ERR)
Q
;
RSLT(GMRCDA,GMRCACT) ;attach or dis-associate results and update
N HL,HLL,SEG,GMRC773,GMRCIQT
S SEG=1
K ^TMP("HLS",$J)
D INIT^HLFNC2("GMRC IFC ORM EVENT",.HL)
I $G(HL) D Q ; if HL array can't be built, log it with an error
. D LOGMSG^GMRCIUTL(GMRCDA,GMRCACT,,904)
D I $D(GMRCIQT) D NOMPI(GMRCDA,GMRCACT) Q ;build PID seg if nat'l ICN
. N GMRCDFN S GMRCDFN=$P(^GMR(123,+GMRCDA,0),U,2)
. I '$G(GMRCDFN) S GMRCIQT=1 Q
. I $$GETICN^MPIF001(GMRCDFN)<1 S GMRCIQT=1 Q
. I $$IFLOCAL^MPIF001(GMRCDFN) S GMRCIQT=1 Q
. S ^TMP("HLS",$J,SEG)=$$EN^VAFCPID(GMRCDFN,"1,2,3,4,5,7,8,19")
. ;
. ; If remote site is converted, enhance the PID segment. p184
. ;
. I $$CNVTD(GMRCDA)=1 S ^TMP("HLS",$J,SEG)=$$ADD2PID^GMRCIUTL(^TMP("HLS",$J,SEG),GMRCDFN,$P($G(^GMR(123,GMRCDA,"CERNER")),U,3)) ;
. ;
. S SEG=SEG+1
. Q
D ;build ORC seg based on GMRCACT
. N ACTVT,OC,OS
. S ACTVT=$P(^GMR(123,GMRCDA,40,GMRCACT,0),U,2) ; get activity
. S OC="RE"
. S OS=$S(ACTVT=9:"A",ACTVT=12:"IP",1:"CM") ; A=part res CM=comp IP=dis
. S ^TMP("HLS",$J,SEG)=$$ORC^GMRCISEG(GMRCDA,OC,OS,GMRCACT)
. S SEG=SEG+1
;
; If remote site is converted, add OBR segment. p184
;
I $$CNVTD(GMRCDA)=1 D ;
. S ^TMP("HLS",$J,SEG)=$$OBR^GMRCISG1(GMRCDA) ;
. S ^TMP("HLS",$J,SEG)=$$ADD2OBR^GMRCIUTL(^TMP("HLS",$J,SEG),GMRCDA) ;
. S SEG=SEG+1
;
I $P(^GMR(123,GMRCDA,40,GMRCACT,0),U,2)'=99 D
. S ^TMP("HLS",$J,SEG)=$$OBXRSLT^GMRCISEG(GMRCDA,GMRCACT)
. S SEG=SEG+1
S ^TMP("HLS",$J,SEG)=$$OBXTZ^GMRCISEG ;always include local time zone
S HLL("LINKS",1)=$$ROUTE(GMRCDA) I '$L(HLL("LINKS",1)) D Q ;log error
. D:'$$EXIST201^GMRCIEV1(IEN,GMRCACT) LOGMSG^GMRCIUTL(IEN,ACTN,"",903) ;MKN GMRC*3*154 '$$EXIST201
S HLP("SUBSCRIBER")="^^^^"_$P(HLL("LINKS",1),U,3) ;MKN GMRC*3*154 Station coming back from $$ROUTE
D GENERATE^HLMA("GMRC IFC ORM EVENT","GM",1,.GMRC773,,.HLP) ;MKN GMRC*3*154 added 6th parameter that passes subscriber to HLP array in GENERATE^HLMA
N ERR S ERR=$S($P(GMRC773,U,2):904,1:"") ; if err from HL7, log it
D LOGMSG^GMRCIUTL(GMRCDA,GMRCACT,+GMRC773,ERR)
Q
;
NOMPI(GMRCIEN,GMRCACTV) ;process MPI exception
N GMRCDFN
S GMRCDFN=$P(^GMR(123,GMRCIEN,0),U,2)
D PTMPIER^GMRCIERR(GMRCDFN) ; send msg to local group for ICN problem
D LOGMSG^GMRCIUTL(GMRCIEN,GMRCACTV,,202) ;put inc. entry in MSG log
Q
;
ROUTE(GMRCDA) ; determine correct routing for IFC msg
; Input:
; GMRCDA = ien from file 123
;
; Output:
; the logical link to send the message to in format
; "GMRC IFC SUBSC^VHAHIN^STATION"
;
N SITE,STA ;
S SITE=$P(^GMR(123,GMRCDA,0),U,23) I 'SITE Q "" ;no ROUTING FACILITY
S STA=$$STA^XUAF4(SITE) I '$L(STA) Q "" ;can't find station num for that site
;
; Converted site
;
I $$CRNRSITE^VAFCCRNR(STA)=1 Q "GMRC IFC SUBSC^"_$$GET^XPAR("SYS","GMRC IFC REGIONAL ROUTER",1)_U_STA ;
;
; Non-converted site
;
N GMRCLINK,SUB,DATA ;
I $$CRNRSITE^VAFCCRNR(STA)'=1 D LINK^HLUTIL3(STA,.GMRCLINK,"I") S SUB=$O(GMRCLINK(0)) I SUB S DATA=GMRCLINK(SUB) Q "GMRC IFC SUBSC^"_DATA_U_STA ;
;
Q "" ;
;
CNVTD(GMRCDA) ; had facility been converted
; Input:
; GMRCDA = ien from file 123
;
; Output:
; 1 = converted site
; 0 = not converted or unknown based on missing data
N SITE,STA
N DGKEY,DGOUT,CNT,IDS,CONSULTDFN,GMRCDFN
S CONSULTDFN=""
S SITE=$P($G(^GMR(123,GMRCDA,0)),U,23) I 'SITE Q 0 ;no ROUTING FACILITY
S STA=$$STA^XUAF4(SITE)
I '$L(STA) Q 0 ;can't find station num for that site
;
S GMRCDFN=$P(^GMR(123,GMRCDA,0),U,2) ;get patient
I 'GMRCDFN Q 0
;
;pull patient Correlation list
S DGKEY=GMRCDFN_U_"PI"_U_"USVHA"_U_$P($$SITE^VASITE,"^",3)
D TFL^VAFCTFU2(.DGOUT,DGKEY)
;
S CNT=0 F S CNT=$O(DGOUT(CNT)) Q:'CNT S IDS=$G(DGOUT(CNT)) I $P(IDS,"^",4)=STA,$P(IDS,"^",5)="C" S CONSULTDFN=IDS Q
;
Q $S(CONSULTDFN]"":1,1:0)
;
;MKN GMRC*3.0*154 Start mods - Check PT correlation and do proxy add if required
CHKCORR(GMRCDA) ;
;
; Returns "1^ADDED" if proxy add succeeded, 1 if patient known to Cerner or site is non-converted and 0 if not. p189 wtc 12/5/23, 4/4/24
;
N CERNERID,CNT,CONSULTDFN,DGKEY,DGOUT,GMRCDFN,IDS,SITE,STA,RTNCODE ;
S GMRCDFN=$P(^GMR(123,GMRCDA,0),U,2) I 'GMRCDFN Q 0 ;
;
S SITE=$P(^GMR(123,GMRCDA,0),U,23) I 'SITE Q 0 ;no ROUTING FACILITY
S STA=$$STA^XUAF4(SITE) I '$L(STA) Q 0 ;can't find station num for that site
;
S (CERNERID,CONSULTDFN)=""
;pull patient Correlation list
S DGKEY=GMRCDFN_U_"PI"_U_"USVHA"_U_$P($$SITE^VASITE,"^",3)
D TFL^VAFCTFU2(.DGOUT,DGKEY)
;
S CNT=0,RTNCODE=0 F S CNT=$O(DGOUT(CNT)) Q:'CNT S IDS=$G(DGOUT(CNT)) D ;
.I $P(IDS,"^",4)="200CRNR",$P(IDS,"^",2)="PI" S CERNERID=IDS ;
.I $P(IDS,"^",4)=STA,$P(IDS,"^",2)="PI",$P(IDS,"^",5)="A"!($P(IDS,"^",5)="C") S CONSULTDFN=IDS ;
;
; Patient known to filler and filler is non-converted VistA.
;
I CONSULTDFN'="",$$CRNRSITE^VAFCCRNR(STA)'=1 Q 1 ;
;
; Filler is Cerner. Patient known to Cerner and its converted VistA.
;
I CERNERID'="",CONSULTDFN'="",$$CRNRSITE^VAFCCRNR(STA)=1 Q 1 ;
;
; Filler is Cerner. Patient known to Cerner but not its converted VistA.
;
I CERNERID'="",CONSULTDFN="",$$CRNRSITE^VAFCCRNR(STA)=1 D Q 1 ; return 1 because response is sent to Cerner not the converted VistA
. S RTNCODE=$$ADD^DGPROSAD($P(CERNERID,U,1)_"~USDOD~NI~200DOD",STA) ; ICR 7421
. I RTNCODE<0 D FAILPRXY^GMRCIUT1("",$P(CERNERID,U,1),GMRCDA,"","","",STA,$P(RTNCODE,U,2)) Q ; P189 WTC 6/24/24
;
; if not known to filler, trigger Proxy Add Patient
;
I CONSULTDFN=""!(CERNERID="") S RTNCODE=$$PROXYADD(GMRCDA,GMRCDFN,STA) ;
Q RTNCODE ;
;
PROXYADD(GMRCDA,GMRCDFN,STA) ;
;
; Adds patient to Cerner or non-converted VistA. Returns "1^ADDED" if successful and 0 if not. p189 wtc 12/5/23
;
N CONSULTDFN,MPIDATA,PATARR
S CONSULTDFN=0
D GETPAT^MPIFRES(GMRCDFN,.PATARR)
S PATARR(1,"preferredFacilityNumber")=STA
S PATARR(1,"AddType")="ADDPREFTF"
D GETICN^MPIFXMLI(.MPIDATA,.PATARR) I +MPIDATA("ICN")>0 S CONSULTDFN=+MPIDATA("ICN")
;
; If proxy add failed, generate 203 error if IFC to Cerner or 201 error otherwise.
;
I +CONSULTDFN=0 D Q 0 ;
. I $$CRNRSITE^VAFCCRNR(STA)=1 D LOGMSG^GMRCIUTL(GMRCDA,1,"",203) Q ;
. I $$CRNRSITE^VAFCCRNR(STA)'=1 D LOGMSG^GMRCIUTL(GMRCDA,1,"",201) Q ;
Q "1^ADDED" ;
;
ISCERNER(IEN) ;Is consult going to Cerner?
;Input:
; IEN = file #123
;Output:
; 1 = Cerner IFC
; 0 = Error - see piece 2 for message
;
N GMRCCNV,GMRCDFN,GMRCKEY,GMRCN,GMRCSITE,GMRCTFL,GMRCX,STA ; p184 WTC 5/1/22
S GMRCSITE=$P(^GMR(123,IEN,0),U,23) I 'GMRCSITE Q "0^No ROUTING FACILITY found" Q
S STA=$$STA^XUAF4(GMRCSITE) I '$L(STA) Q "0^Station not found" ;can't find station num for that site - p184 WTC 5/1/22
S GMRCDFN=$$GET1^DIQ(123,IEN_",",.02,"I") I 'GMRCDFN Q "0^No PATIENT file IEN found in consult #"_IEN
S GMRCKEY=GMRCDFN_U_"PI"_U_"USVHA"_U_$P($$SITE^VASITE,"^",3)
D TFL^VAFCTFU2(.GMRCTFL,GMRCKEY)
S (GMRCCNV,GMRCN)=0 F S GMRCN=$O(GMRCTFL(GMRCN)) Q:'GMRCN S GMRCX=GMRCTFL(GMRCN) D
. I $P(GMRCX,U,4)=STA,$P(GMRCX,U,5)="C" S GMRCCNV=1 Q ; p184 WTC 5/1/22
;It is going to Cerner=converted site, so send all messages
Q GMRCCNV
;
LOC(GMRCLOC,GMRCIENS) ;DETERMINE LOCATION
N LOCNAME
I '$D(^GMR(123,$P(GMRCIENS,",",2),40,$P(GMRCIENS,",",1),3)) D SITE Q GMRCLOC
S LOCNAME=^GMR(123,$P(GMRCIENS,",",2),40,$P(GMRCIENS,",",1),3)
S LOCNAME=$P(LOCNAME,U,3)
S LOCNAME=$P(^DIC(4,LOCNAME,0),U,1)
Q LOCNAME
SITE ;SET LOCAL SITE
S GMRCLOC=$P($$SITE^VASITE,U,2)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRCIEVT 16886 printed Dec 13, 2024@01:46:02 Page 2
GMRCIEVT ;SLC/JFR - process events and build HL7 message; 6/20/2021 09:23 ; Aug 12, 2024@09:30:42
+1 ;;3.0;CONSULT/REQUEST TRACKING;**22,28,31,121,154,184,189**;DEC 27, 1997;Build 54
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ; #7133 GETPAT MPIFRES, #7134 GETICN MPIFXMLI, #2161 HFLNC2, #2164 HLMA, #2271 HLUTIL3, #2701 MPIF001, #3015 VAFCPID, #4648 VAFCTFU2, #10112 VASITE
+4 ; #2053 DIE, #2056 DIQ, #2171 XUAF4, #2263 XPAR
+5 ; Reference to $$ADD^DGPROSAD in ICR #7421
+6 ; Reference to $$CRNRSITE^VAFCCRNR in ICR #7346
+7 ;
+8 ;don't start at the top
QUIT
TRIGR(IEN,ACTN) ;determine what action was taken on IFC and call event point
+1 ;Input:
+2 ; IEN = consult number from file 123
+3 ; ACT = ien in 40 multiple corresponding to activity
+4 ;
+5 ;CLT, GMRC*3.0*184, Do not send a msg back on receipt of a comment from
+6 ; cerner. That causes a duplicate entry at cerner.
+7 NEW GMRCDQ,GMRCDQ1
SET GMRCDQ=0
+8 SET GMRCDQ1=$$NOSND^GMRCIUTL()
IF GMRCDQ1=1
QUIT
+9 NEW ACTYPE
+10 SET ACTYPE=$PIECE(^GMR(123,IEN,40,ACTN,0),U,2)
+11 IF 'ACTYPE
QUIT
+12 ;don't send admin corrections yet...
IF ACTYPE=26
QUIT
+13 ;
+14 ; check bkgrd job and run if overdue
+15 IF '$DATA(ZTQUEUED)
IF $$GONOGO^GMRCIBKG
Begin DoDot:1
+16 ;remove ZTQUEUED?
NEW ZTQUEUED
SET ZTQUEUED=1
DO EN^GMRCIBKG
End DoDot:1
+17 ;
+18 ;earlier pending activities
IF $ORDER(^GMR(123.6,"AC",IEN,ACTN),-1)
Begin DoDot:1
+19 ; not a trigger or not done here
IF ACTYPE=22
QUIT
+20 IF ACTYPE=6
NEW GMRCQT
Begin DoDot:2
+21 ;complete all transactions if IFC DC'd before request ever sent
+22 ;new request already sent
IF $ORDER(^GMR(123.6,"AC",IEN,ACTN),-1)'=1
QUIT
+23 SET GMRCQT=1
+24 NEW DA,DIE,DR,GMRCACTS
+25 SET GMRCACTS=0
+26 FOR
SET GMRCACTS=$ORDER(^GMR(123.6,"AC",IEN,GMRCACTS))
if 'GMRCACTS
QUIT
Begin DoDot:3
+27 SET DIE="^GMR(123.6,"
SET DA=$ORDER(^GMR(123.6,"AC",IEN,GMRCACTS,1,0))
+28 SET DR=".06///@"
DO ^DIE
End DoDot:3
End DoDot:2
IF $DATA(GMRCQT)
QUIT
+29 ;msg log entry but no msg sent
DO LOGMSG^GMRCIUTL(IEN,ACTN,"",902)
End DoDot:1
QUIT
+30 ;send new order - Added ACTN as parameter. P189 WTC 6/24/2024
IF ACTYPE=2!(ACTYPE=1)
DO NW(IEN,ACTN)
QUIT
+31 ;inc report or add'l notes
IF ACTYPE=9!(ACTYPE=14)
DO RSLT(IEN,ACTN)
QUIT
+32 ;comp
IF ACTYPE=10
IF $PIECE(^GMR(123,IEN,40,ACTN,0),U,9)
DO RSLT(IEN,ACTN)
QUIT
+33 ;dis-associate result
IF ACTYPE=12
DO RSLT(IEN,ACTN)
QUIT
+34 ;ed/resubmit
IF ACTYPE=11
DO RESUB^GMRCIEV1(IEN,ACTN)
QUIT
+35 ; addendum added
IF ACTYPE=13
DO RSLT(IEN,ACTN)
QUIT
+36 ; sig finding update
IF ACTYPE=4
DO SF^GMRCIEV1(IEN,ACTN)
QUIT
+37 ;printed to is not a trigger
IF ACTYPE=22
QUIT
+38 ; forward
IF ACTYPE=17
DO FWD^GMRCIEV1(IEN,ACTN)
QUIT
+39 ; FWD into an IFC service
IF ACTYPE=25
DO FWD2IFC^GMRCIEV1(IEN,ACTN)
QUIT
+40 ;all other updates
DO GENUPD(IEN,ACTN)
+41 QUIT
NW(GMRCDA,ACTN) ;build new order message for IFC
+1 ; Input:
+2 ; GMRCDA = ien from file 123
+3 ;
+4 ;
NEW HL,HLL,SEG,GMRC773,GMRCIQT,GMRCPD,PROXYADD,GMRCDFN,STA,SITE
+5 ;
+6 ;MKN GMRC*3.0*154 Check PT correlation and do proxy add if required, changed to function p189 wtc 12/5/23
SET PROXYADD=$$CHKCORR(GMRCDA)
if 'PROXYADD
QUIT
+7 SET SEG=1
+8 KILL ^TMP("HLS",$JOB)
+9 DO INIT^HLFNC2("GMRC IFC ORM EVENT",.HL)
+10 ; if HL array can't be built, log it with an error
IF $GET(HL)
Begin DoDot:1
+11 ;MKN GMRC*3.0*154 GMRCACT to ACTN
DO LOGMSG^GMRCIUTL(GMRCDA,ACTN,,904)
End DoDot:1
QUIT
+12 ;build PID seg if not a local ICN
Begin DoDot:1
+13 SET GMRCDFN=$PIECE(^GMR(123,+GMRCDA,0),U,2)
+14 IF '$GET(GMRCDFN)
SET GMRCIQT=1
QUIT
+15 IF $$GETICN^MPIF001(GMRCDFN)<1
SET GMRCIQT=1
QUIT
+16 IF $$IFLOCAL^MPIF001(GMRCDFN)
SET GMRCIQT=1
QUIT
+17 SET ^TMP("HLS",$JOB,SEG)=$$EN^VAFCPID(GMRCDFN,"1,2,3,4,5,7,8,19")
+18 ;
+19 ; If remote site is converted, enhance the PID segment. p184
+20 ;
+21 ;
IF $$CNVTD(GMRCDA)=1
SET ^TMP("HLS",$JOB,SEG)=$$ADD2PID^GMRCIUTL(^TMP("HLS",$JOB,SEG),GMRCDFN,$PIECE($GET(^GMR(123,GMRCDA,"CERNER")),U,3))
+22 ;
+23 SET SEG=SEG+1
+24 QUIT
End DoDot:1
IF $DATA(GMRCIQT)
DO NOMPI(GMRCDA,1)
QUIT
+25 ; get ORC for new ord
SET ^TMP("HLS",$JOB,SEG)=$$NWORC^GMRCISG1(GMRCDA)
+26 SET SEG=SEG+1
+27 ;get OBR segment
SET ^TMP("HLS",$JOB,SEG)=$$OBR^GMRCISG1(GMRCDA)
+28 ;
+29 ; If remote site is converted, enhance the OBR segment. p184
+30 ;
+31 ;
IF $$CNVTD(GMRCDA)=1
SET ^TMP("HLS",$JOB,SEG)=$$ADD2OBR^GMRCIUTL(^TMP("HLS",$JOB,SEG),GMRCDA)
+32 ;
+33 SET SEG=SEG+1
+34 ;build reason for request into OBX segment(s)
Begin DoDot:1
+35 KILL ^TMP("GMRCRFR",$JOB)
+36 DO OBXWP^GMRCISEG(GMRCDA,"NW",1,$NAME(^TMP("GMRCRFR",$JOB)))
+37 IF '$DATA(^TMP("GMRCRFR",$JOB))
QUIT
+38 NEW I
SET I=0
+39 FOR
SET I=$ORDER(^TMP("GMRCRFR",$JOB,I))
if 'I
QUIT
Begin DoDot:2
+40 SET ^TMP("HLS",$JOB,SEG)=^TMP("GMRCRFR",$JOB,I)
+41 SET SEG=SEG+1
End DoDot:2
+42 KILL ^TMP("GMRCRFR",$JOB)
+43 QUIT
End DoDot:1
+44 ;bl;154 preventing blank line for OBX
SET GMRCPD=$$OBXPD^GMRCISG1(GMRCDA)
+45 ; build prov DX in OBX
IF GMRCPD'=""
SET ^TMP("HLS",$JOB,SEG)=GMRCPD
+46 SET SEG=SEG+1
+47 ;always send local time zone
SET ^TMP("HLS",$JOB,SEG)=$$OBXTZ^GMRCISEG
+48 ;
+49 ;AV/MKN Add NTE segment to HL7 to send UCID file #123, field #80 *121*
+50 NEW SEP
+51 SET SEP=HL("FS")
+52 NEW UCID
SET UCID=$$GET1^DIQ(123,GMRCDA,80)
if UCID]""
SET SEG=SEG+1
SET ^TMP("HLS",$JOB,SEG)="NTE"_SEP_"P"_SEP_"UCID:"_UCID
+53 ;AV/MKN End of NTE for UCID *121*
+54 ;
+55 ;no ROUTING FACILITY
SET SITE=$PIECE(^GMR(123,GMRCDA,0),U,23)
IF 'SITE
DO LOGMSG^GMRCIUTL(IEN,ACTN,"",903)
QUIT
+56 ;can't find station num for that site
SET STA=$$STA^XUAF4(SITE)
IF '$LENGTH(STA)
DO LOGMSG^GMRCIUTL(IEN,ACTN,"",903)
QUIT
+57 ;
+58 ; If patient just proxy added, generate error 205 if not completed yet. p189 wtc 6/18/2024
+59 ;
+60 ;
IF $PIECE(PROXYADD,U,2)="ADDED"
IF +$$CHKPROXY^GMRCIUT1(GMRCDA,GMRCDFN,STA)=0
DO LOGMSG^GMRCIUTL(IEN,ACTN,"",205)
QUIT
+61 ;
+62 ; Otherwise, set route according to whether destination site is converted (use $$GET^XPAR("SYS","GMRC IFC REGIONAL ROUTER",1)) or non-converted (use D LINK^HLUTIL3(STA,.GMRCLINK,"I"))
+63 ;
+64 ;log error
SET HLL("LINKS",1)=$$ROUTE(GMRCDA)
IF '$LENGTH(HLL("LINKS",1))
Begin DoDot:1
+65 ;MKN GMRC*3*154 '$$EXIST201
if '$$EXIST201^GMRCIEV1(GMRCDA,GMRCACT)
DO LOGMSG^GMRCIUTL(GMRCDA,GMRCACT,"",903)
End DoDot:1
QUIT
+66 ;MKN GMRC*3*154 Station coming back from $$ROUTE
SET HLP("SUBSCRIBER")="^^^^"_$PIECE(HLL("LINKS",1),U,3)
+67 ;MKN GMRC*3*154 added 6th parameter that passes to HLP array in GENERATE^HLMA
DO GENERATE^HLMA("GMRC IFC ORM EVENT","GM",1,.GMRC773,,.HLP)
+68 NEW ERR
SET ERR=$SELECT($PIECE(GMRC773,U,2):904,1:"")
+69 ;
+70 DO LOGMSG^GMRCIUTL(GMRCDA,1,+GMRC773,ERR)
+71 QUIT
+72 ;
GENUPD(GMRCDA,GMRCACT) ;build msg and send upon REC, SC or ADD CMT event
+1 ; P184
NEW HL,HLL,SEG,GMRC773,GMRCCRNR,GMRCIQT,OBR,PROSTHCS
+2 ; p184
NEW EDIPI,ICN,PTACCTNO,FS,CS,REPTTN
SET PTACCTNO=$PIECE($GET(^GMR(123,GMRCDA,"CERNER")),U,3)
+3 SET SEG=1
+4 KILL ^TMP("HLS",$JOB)
+5 DO INIT^HLFNC2("GMRC IFC ORM EVENT",.HL)
+6 ; if HL array can't be built, log it with an error
IF $GET(HL)
Begin DoDot:1
+7 DO LOGMSG^GMRCIUTL(GMRCDA,GMRCACT,,904)
End DoDot:1
QUIT
+8 ;build PID seg if nat'l ICN
Begin DoDot:1
+9 NEW GMRCDFN
SET GMRCDFN=$PIECE(^GMR(123,+GMRCDA,0),U,2)
+10 IF '$GET(GMRCDFN)
SET GMRCIQT=1
QUIT
+11 IF $$GETICN^MPIF001(GMRCDFN)<1
SET GMRCIQT=1
QUIT
+12 IF $$IFLOCAL^MPIF001(GMRCDFN)
SET GMRCIQT=1
QUIT
+13 SET ^TMP("HLS",$JOB,SEG)=$$EN^VAFCPID(GMRCDFN,"1,2,3,4,5,7,8,19")
+14 ;
+15 ; If remote site is converted, enhance the PID segment. p184
+16 ;
+17 ;
IF $$CNVTD(GMRCDA)=1
SET ^TMP("HLS",$JOB,SEG)=$$ADD2PID^GMRCIUTL(^TMP("HLS",$JOB,SEG),GMRCDFN,PTACCTNO)
+18 ;
SET SEG=SEG+1
+19 QUIT
End DoDot:1
IF $DATA(GMRCIQT)
DO NOMPI(GMRCDA,GMRCACT)
QUIT
+20 ;build ORC seg based on GMRCACT
Begin DoDot:1
+21 NEW ACTVT,OC,OS
+22 ; get activity
SET ACTVT=$PIECE(^GMR(123,GMRCDA,40,GMRCACT,0),U,2)
+23 ;set order control for ORC seg:
+24 ; v-- IP=cmt RE=adm comp OD=DC OC=cancel SC=sch or receive
+25 SET OC=$SELECT(ACTVT=20:"IP",ACTVT=10:"RE",ACTVT=6:"OD",ACTVT=19:"OC",1:"SC")
+26 ;set order status for ORC seg:
+27 ; v-- SC=sch RE=adm comp DC=DC CA=cancel IP=cmt or receive
+28 SET OS=$SELECT(ACTVT=8:"SC",ACTVT=10:"CM",ACTVT=6:"DC",ACTVT=19:"CA",1:"IP")
+29 SET ^TMP("HLS",$JOB,SEG)=$$ORC^GMRCISEG(GMRCDA,OC,OS,GMRCACT)
+30 SET SEG=SEG+1
+31 QUIT
End DoDot:1
+32 ;
+33 ; Generate OBR segment if IFC is from converted site. p184
+34 ;
+35 ;
IF $$CNVTD(GMRCDA)=1
Begin DoDot:1
+36 ;
+37 ;
SET OBR=$$OBR^GMRCISG1(GMRCDA)
+38 ;
SET OBR=$$ADD2OBR^GMRCIUTL(OBR,GMRCDA)
+39 ;
SET ^TMP("HLS",$JOB,SEG)=OBR
+40 ;
SET SEG=SEG+1
End DoDot:1
+41 ;
+42 ; Determine if order is for Prosthetics - p184 WTC 6/1/22
+43 ;
+44 ; P184
SET PROSTHCS=$SELECT($GET(OBR)="":0,$PIECE($PIECE(OBR,"|",5),U,2)["PROSTHETICS IFC":1,1:0)
+45 ;
+46 ;send sig findings
IF $LENGTH($PIECE(^GMR(123,GMRCDA,0),U,19))
Begin DoDot:1
+47 SET ^TMP("HLS",$JOB,SEG)=$$OBXSF^GMRCISEG(GMRCDA)
+48 SET SEG=SEG+1
End DoDot:1
+49 ;load up a comment if there
IF $ORDER(^GMR(123,GMRCDA,40,GMRCACT,1,0))
Begin DoDot:1
+50 NEW I
+51 KILL ^TMP("GMRCMT",$JOB)
+52 ;MKN 184
SET GMRCCRNR=$$ISCERNER(GMRCDA)
+53 IF $PIECE(^TMP("HLS",$JOB,SEG-1),"|",2)'["O"
Begin DoDot:2
+54 ; p184 - wtc 6/1/22
if GMRCCRNR&'PROSTHCS
DO CRNROBX^GMRCIEV1(GMRCDA,$NAME(^TMP("GMRCMT",$JOB)))
+55 ; p184 - wtc 6/1/22
if 'GMRCCRNR!PROSTHCS
DO OBXWP^GMRCISEG(GMRCDA,"",GMRCACT,$NAME(^TMP("GMRCMT",$JOB)))
End DoDot:2
+56 IF $PIECE(^TMP("HLS",$JOB,SEG-1),"|",2)["O"
Begin DoDot:2
+57 ; p184 - wtc 6/1/22
IF GMRCCRNR
IF 'PROSTHCS
DO CRNRNTE^GMRCIEV1(GMRCDA,$NAME(^TMP("GMRCMT",$JOB)))
+58 ; p184 - wtc 6/1/22
IF 'GMRCCRNR!PROSTHCS
NEW GMRCMT
DO NTE^GMRCISEG(GMRCDA,GMRCACT,.GMRCMT)
IF $DATA(GMRCMT)
MERGE ^TMP("GMRCMT",$JOB)=GMRCMT
End DoDot:2
+59 if '$ORDER(^TMP("GMRCMT",$JOB,0))
QUIT
+60 SET I=0
FOR
SET I=$ORDER(^TMP("GMRCMT",$JOB,I))
if 'I
QUIT
Begin DoDot:2
+61 SET ^TMP("HLS",$JOB,SEG)=^TMP("GMRCMT",$JOB,I)
+62 SET SEG=SEG+1
End DoDot:2
+63 KILL ^TMP("GMRCMT",$JOB)
+64 QUIT
End DoDot:1
+65 ;always include local time zone
SET ^TMP("HLS",$JOB,SEG)=$$OBXTZ^GMRCISEG
+66 ;log error
SET HLL("LINKS",1)=$$ROUTE(GMRCDA)
IF '$LENGTH(HLL("LINKS",1))
Begin DoDot:1
+67 ;MKN GMRC*3*154 '$$EXIST201
if '$$EXIST201^GMRCIEV1(GMRCDA,GMRCACT)
DO LOGMSG^GMRCIUTL(GMRCDA,GMRCACT,"",903)
End DoDot:1
QUIT
+68 ;MKN GMRC*3*154 Station coming back from $$ROUTE
SET HLP("SUBSCRIBER")="^^^^"_$PIECE(HLL("LINKS",1),U,3)
+69 ;
+70 ;MKN GMRC*3*154 added 6th parameter that passes to HLP array in GENERATE^HLMA
DO GENERATE^HLMA("GMRC IFC ORM EVENT","GM",1,.GMRC773,,.HLP)
+71 ; if err from HL7, log it
NEW ERR
SET ERR=$SELECT($PIECE(GMRC773,U,2):904,1:"")
+72 DO LOGMSG^GMRCIUTL(GMRCDA,GMRCACT,+GMRC773,ERR)
+73 QUIT
+74 ;
RSLT(GMRCDA,GMRCACT) ;attach or dis-associate results and update
+1 NEW HL,HLL,SEG,GMRC773,GMRCIQT
+2 SET SEG=1
+3 KILL ^TMP("HLS",$JOB)
+4 DO INIT^HLFNC2("GMRC IFC ORM EVENT",.HL)
+5 ; if HL array can't be built, log it with an error
IF $GET(HL)
Begin DoDot:1
+6 DO LOGMSG^GMRCIUTL(GMRCDA,GMRCACT,,904)
End DoDot:1
QUIT
+7 ;build PID seg if nat'l ICN
Begin DoDot:1
+8 NEW GMRCDFN
SET GMRCDFN=$PIECE(^GMR(123,+GMRCDA,0),U,2)
+9 IF '$GET(GMRCDFN)
SET GMRCIQT=1
QUIT
+10 IF $$GETICN^MPIF001(GMRCDFN)<1
SET GMRCIQT=1
QUIT
+11 IF $$IFLOCAL^MPIF001(GMRCDFN)
SET GMRCIQT=1
QUIT
+12 SET ^TMP("HLS",$JOB,SEG)=$$EN^VAFCPID(GMRCDFN,"1,2,3,4,5,7,8,19")
+13 ;
+14 ; If remote site is converted, enhance the PID segment. p184
+15 ;
+16 ;
IF $$CNVTD(GMRCDA)=1
SET ^TMP("HLS",$JOB,SEG)=$$ADD2PID^GMRCIUTL(^TMP("HLS",$JOB,SEG),GMRCDFN,$PIECE($GET(^GMR(123,GMRCDA,"CERNER")),U,3))
+17 ;
+18 SET SEG=SEG+1
+19 QUIT
End DoDot:1
IF $DATA(GMRCIQT)
DO NOMPI(GMRCDA,GMRCACT)
QUIT
+20 ;build ORC seg based on GMRCACT
Begin DoDot:1
+21 NEW ACTVT,OC,OS
+22 ; get activity
SET ACTVT=$PIECE(^GMR(123,GMRCDA,40,GMRCACT,0),U,2)
+23 SET OC="RE"
+24 ; A=part res CM=comp IP=dis
SET OS=$SELECT(ACTVT=9:"A",ACTVT=12:"IP",1:"CM")
+25 SET ^TMP("HLS",$JOB,SEG)=$$ORC^GMRCISEG(GMRCDA,OC,OS,GMRCACT)
+26 SET SEG=SEG+1
End DoDot:1
+27 ;
+28 ; If remote site is converted, add OBR segment. p184
+29 ;
+30 ;
IF $$CNVTD(GMRCDA)=1
Begin DoDot:1
+31 ;
SET ^TMP("HLS",$JOB,SEG)=$$OBR^GMRCISG1(GMRCDA)
+32 ;
SET ^TMP("HLS",$JOB,SEG)=$$ADD2OBR^GMRCIUTL(^TMP("HLS",$JOB,SEG),GMRCDA)
+33 SET SEG=SEG+1
End DoDot:1
+34 ;
+35 IF $PIECE(^GMR(123,GMRCDA,40,GMRCACT,0),U,2)'=99
Begin DoDot:1
+36 SET ^TMP("HLS",$JOB,SEG)=$$OBXRSLT^GMRCISEG(GMRCDA,GMRCACT)
+37 SET SEG=SEG+1
End DoDot:1
+38 ;always include local time zone
SET ^TMP("HLS",$JOB,SEG)=$$OBXTZ^GMRCISEG
+39 ;log error
SET HLL("LINKS",1)=$$ROUTE(GMRCDA)
IF '$LENGTH(HLL("LINKS",1))
Begin DoDot:1
+40 ;MKN GMRC*3*154 '$$EXIST201
if '$$EXIST201^GMRCIEV1(IEN,GMRCACT)
DO LOGMSG^GMRCIUTL(IEN,ACTN,"",903)
End DoDot:1
QUIT
+41 ;MKN GMRC*3*154 Station coming back from $$ROUTE
SET HLP("SUBSCRIBER")="^^^^"_$PIECE(HLL("LINKS",1),U,3)
+42 ;MKN GMRC*3*154 added 6th parameter that passes subscriber to HLP array in GENERATE^HLMA
DO GENERATE^HLMA("GMRC IFC ORM EVENT","GM",1,.GMRC773,,.HLP)
+43 ; if err from HL7, log it
NEW ERR
SET ERR=$SELECT($PIECE(GMRC773,U,2):904,1:"")
+44 DO LOGMSG^GMRCIUTL(GMRCDA,GMRCACT,+GMRC773,ERR)
+45 QUIT
+46 ;
NOMPI(GMRCIEN,GMRCACTV) ;process MPI exception
+1 NEW GMRCDFN
+2 SET GMRCDFN=$PIECE(^GMR(123,GMRCIEN,0),U,2)
+3 ; send msg to local group for ICN problem
DO PTMPIER^GMRCIERR(GMRCDFN)
+4 ;put inc. entry in MSG log
DO LOGMSG^GMRCIUTL(GMRCIEN,GMRCACTV,,202)
+5 QUIT
+6 ;
ROUTE(GMRCDA) ; determine correct routing for IFC msg
+1 ; Input:
+2 ; GMRCDA = ien from file 123
+3 ;
+4 ; Output:
+5 ; the logical link to send the message to in format
+6 ; "GMRC IFC SUBSC^VHAHIN^STATION"
+7 ;
+8 ;
NEW SITE,STA
+9 ;no ROUTING FACILITY
SET SITE=$PIECE(^GMR(123,GMRCDA,0),U,23)
IF 'SITE
QUIT ""
+10 ;can't find station num for that site
SET STA=$$STA^XUAF4(SITE)
IF '$LENGTH(STA)
QUIT ""
+11 ;
+12 ; Converted site
+13 ;
+14 ;
IF $$CRNRSITE^VAFCCRNR(STA)=1
QUIT "GMRC IFC SUBSC^"_$$GET^XPAR("SYS","GMRC IFC REGIONAL ROUTER",1)_U_STA
+15 ;
+16 ; Non-converted site
+17 ;
+18 ;
NEW GMRCLINK,SUB,DATA
+19 ;
IF $$CRNRSITE^VAFCCRNR(STA)'=1
DO LINK^HLUTIL3(STA,.GMRCLINK,"I")
SET SUB=$ORDER(GMRCLINK(0))
IF SUB
SET DATA=GMRCLINK(SUB)
QUIT "GMRC IFC SUBSC^"_DATA_U_STA
+20 ;
+21 ;
QUIT ""
+22 ;
CNVTD(GMRCDA) ; had facility been converted
+1 ; Input:
+2 ; GMRCDA = ien from file 123
+3 ;
+4 ; Output:
+5 ; 1 = converted site
+6 ; 0 = not converted or unknown based on missing data
+7 NEW SITE,STA
+8 NEW DGKEY,DGOUT,CNT,IDS,CONSULTDFN,GMRCDFN
+9 SET CONSULTDFN=""
+10 ;no ROUTING FACILITY
SET SITE=$PIECE($GET(^GMR(123,GMRCDA,0)),U,23)
IF 'SITE
QUIT 0
+11 SET STA=$$STA^XUAF4(SITE)
+12 ;can't find station num for that site
IF '$LENGTH(STA)
QUIT 0
+13 ;
+14 ;get patient
SET GMRCDFN=$PIECE(^GMR(123,GMRCDA,0),U,2)
+15 IF 'GMRCDFN
QUIT 0
+16 ;
+17 ;pull patient Correlation list
+18 SET DGKEY=GMRCDFN_U_"PI"_U_"USVHA"_U_$PIECE($$SITE^VASITE,"^",3)
+19 DO TFL^VAFCTFU2(.DGOUT,DGKEY)
+20 ;
+21 SET CNT=0
FOR
SET CNT=$ORDER(DGOUT(CNT))
if 'CNT
QUIT
SET IDS=$GET(DGOUT(CNT))
IF $PIECE(IDS,"^",4)=STA
IF $PIECE(IDS,"^",5)="C"
SET CONSULTDFN=IDS
QUIT
+22 ;
+23 QUIT $SELECT(CONSULTDFN]"":1,1:0)
+24 ;
+25 ;MKN GMRC*3.0*154 Start mods - Check PT correlation and do proxy add if required
CHKCORR(GMRCDA) ;
+1 ;
+2 ; Returns "1^ADDED" if proxy add succeeded, 1 if patient known to Cerner or site is non-converted and 0 if not. p189 wtc 12/5/23, 4/4/24
+3 ;
+4 ;
NEW CERNERID,CNT,CONSULTDFN,DGKEY,DGOUT,GMRCDFN,IDS,SITE,STA,RTNCODE
+5 ;
SET GMRCDFN=$PIECE(^GMR(123,GMRCDA,0),U,2)
IF 'GMRCDFN
QUIT 0
+6 ;
+7 ;no ROUTING FACILITY
SET SITE=$PIECE(^GMR(123,GMRCDA,0),U,23)
IF 'SITE
QUIT 0
+8 ;can't find station num for that site
SET STA=$$STA^XUAF4(SITE)
IF '$LENGTH(STA)
QUIT 0
+9 ;
+10 SET (CERNERID,CONSULTDFN)=""
+11 ;pull patient Correlation list
+12 SET DGKEY=GMRCDFN_U_"PI"_U_"USVHA"_U_$PIECE($$SITE^VASITE,"^",3)
+13 DO TFL^VAFCTFU2(.DGOUT,DGKEY)
+14 ;
+15 ;
SET CNT=0
SET RTNCODE=0
FOR
SET CNT=$ORDER(DGOUT(CNT))
if 'CNT
QUIT
SET IDS=$GET(DGOUT(CNT))
Begin DoDot:1
+16 ;
IF $PIECE(IDS,"^",4)="200CRNR"
IF $PIECE(IDS,"^",2)="PI"
SET CERNERID=IDS
+17 ;
IF $PIECE(IDS,"^",4)=STA
IF $PIECE(IDS,"^",2)="PI"
IF $PIECE(IDS,"^",5)="A"!($PIECE(IDS,"^",5)="C")
SET CONSULTDFN=IDS
End DoDot:1
+18 ;
+19 ; Patient known to filler and filler is non-converted VistA.
+20 ;
+21 ;
IF CONSULTDFN'=""
IF $$CRNRSITE^VAFCCRNR(STA)'=1
QUIT 1
+22 ;
+23 ; Filler is Cerner. Patient known to Cerner and its converted VistA.
+24 ;
+25 ;
IF CERNERID'=""
IF CONSULTDFN'=""
IF $$CRNRSITE^VAFCCRNR(STA)=1
QUIT 1
+26 ;
+27 ; Filler is Cerner. Patient known to Cerner but not its converted VistA.
+28 ;
+29 ; return 1 because response is sent to Cerner not the converted VistA
IF CERNERID'=""
IF CONSULTDFN=""
IF $$CRNRSITE^VAFCCRNR(STA)=1
Begin DoDot:1
+30 ; ICR 7421
SET RTNCODE=$$ADD^DGPROSAD($PIECE(CERNERID,U,1)_"~USDOD~NI~200DOD",STA)
+31 ; P189 WTC 6/24/24
IF RTNCODE<0
DO FAILPRXY^GMRCIUT1("",$PIECE(CERNERID,U,1),GMRCDA,"","","",STA,$PIECE(RTNCODE,U,2))
QUIT
End DoDot:1
QUIT 1
+32 ;
+33 ; if not known to filler, trigger Proxy Add Patient
+34 ;
+35 ;
IF CONSULTDFN=""!(CERNERID="")
SET RTNCODE=$$PROXYADD(GMRCDA,GMRCDFN,STA)
+36 ;
QUIT RTNCODE
+37 ;
PROXYADD(GMRCDA,GMRCDFN,STA) ;
+1 ;
+2 ; Adds patient to Cerner or non-converted VistA. Returns "1^ADDED" if successful and 0 if not. p189 wtc 12/5/23
+3 ;
+4 NEW CONSULTDFN,MPIDATA,PATARR
+5 SET CONSULTDFN=0
+6 DO GETPAT^MPIFRES(GMRCDFN,.PATARR)
+7 SET PATARR(1,"preferredFacilityNumber")=STA
+8 SET PATARR(1,"AddType")="ADDPREFTF"
+9 DO GETICN^MPIFXMLI(.MPIDATA,.PATARR)
IF +MPIDATA("ICN")>0
SET CONSULTDFN=+MPIDATA("ICN")
+10 ;
+11 ; If proxy add failed, generate 203 error if IFC to Cerner or 201 error otherwise.
+12 ;
+13 ;
IF +CONSULTDFN=0
Begin DoDot:1
+14 ;
IF $$CRNRSITE^VAFCCRNR(STA)=1
DO LOGMSG^GMRCIUTL(GMRCDA,1,"",203)
QUIT
+15 ;
IF $$CRNRSITE^VAFCCRNR(STA)'=1
DO LOGMSG^GMRCIUTL(GMRCDA,1,"",201)
QUIT
End DoDot:1
QUIT 0
+16 ;
QUIT "1^ADDED"
+17 ;
ISCERNER(IEN) ;Is consult going to Cerner?
+1 ;Input:
+2 ; IEN = file #123
+3 ;Output:
+4 ; 1 = Cerner IFC
+5 ; 0 = Error - see piece 2 for message
+6 ;
+7 ; p184 WTC 5/1/22
NEW GMRCCNV,GMRCDFN,GMRCKEY,GMRCN,GMRCSITE,GMRCTFL,GMRCX,STA
+8 SET GMRCSITE=$PIECE(^GMR(123,IEN,0),U,23)
IF 'GMRCSITE
QUIT "0^No ROUTING FACILITY found"
QUIT
+9 ;can't find station num for that site - p184 WTC 5/1/22
SET STA=$$STA^XUAF4(GMRCSITE)
IF '$LENGTH(STA)
QUIT "0^Station not found"
+10 SET GMRCDFN=$$GET1^DIQ(123,IEN_",",.02,"I")
IF 'GMRCDFN
QUIT "0^No PATIENT file IEN found in consult #"_IEN
+11 SET GMRCKEY=GMRCDFN_U_"PI"_U_"USVHA"_U_$PIECE($$SITE^VASITE,"^",3)
+12 DO TFL^VAFCTFU2(.GMRCTFL,GMRCKEY)
+13 SET (GMRCCNV,GMRCN)=0
FOR
SET GMRCN=$ORDER(GMRCTFL(GMRCN))
if 'GMRCN
QUIT
SET GMRCX=GMRCTFL(GMRCN)
Begin DoDot:1
+14 ; p184 WTC 5/1/22
IF $PIECE(GMRCX,U,4)=STA
IF $PIECE(GMRCX,U,5)="C"
SET GMRCCNV=1
QUIT
End DoDot:1
+15 ;It is going to Cerner=converted site, so send all messages
+16 QUIT GMRCCNV
+17 ;
LOC(GMRCLOC,GMRCIENS) ;DETERMINE LOCATION
+1 NEW LOCNAME
+2 IF '$DATA(^GMR(123,$PIECE(GMRCIENS,",",2),40,$PIECE(GMRCIENS,",",1),3))
DO SITE
QUIT GMRCLOC
+3 SET LOCNAME=^GMR(123,$PIECE(GMRCIENS,",",2),40,$PIECE(GMRCIENS,",",1),3)
+4 SET LOCNAME=$PIECE(LOCNAME,U,3)
+5 SET LOCNAME=$PIECE(^DIC(4,LOCNAME,0),U,1)
+6 QUIT LOCNAME
SITE ;SET LOCAL SITE
+1 SET GMRCLOC=$PIECE($$SITE^VASITE,U,2)
+2 QUIT
