GMRCIEVT ;SLC/JFR - process events and build HL7 message; 6/20/2021 09:23 ; Jun 02, 2022@09:21:37
;;3.0;CONSULT/REQUEST TRACKING;**22,28,31,121,154,184**;DEC 27, 1997;Build 22
;;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
;
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^GMRCIEVT() 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) Q ;send new order
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) ;build new order message for IFC
; Input:
; GMRCDA = ien from file 123
;
N HL,HLL,SEG,GMRC773,GMRCIQT,GMRCPD
D CHKCORR(GMRCDA) ;MKN GMRC*3.0*154 Check PT correlation and do proxy add if required
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
. 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
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 HLL("LINKS",1)=$$ROUTE(GMRCDA) I '$L(HLL("LINKS",1)) D Q ;log error
. D:'$$EXIST201^GMRCIEV1(IEN,ACTN) 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 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"
;need to understanding their queuing
N SITE,GMRCLINK,STA
N DGKEY,DGOUT,CNT,IDS,CERNERID,CONSULTDFN,GMRCDFN,MPIDATA,RETURN,PATARR,X
S (RETURN,CERNERID,CONSULTDFN)=""
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
;
D LINK^HLUTIL3(STA,.GMRCLINK,"I")
;
;WCJ; if no patient - should not happen
S GMRCDFN=$P(^GMR(123,GMRCDA,0),U,2) I 'GMRCDFN Q ""
;
;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)) D
.I $P(IDS,"^",4)="200CRNR" I $P(IDS,"^",2)="PI" S CERNERID=IDS
.I $P(IDS,"^",4)=STA I $P(IDS,"^",2)="PI" I $P(IDS,"^",5)="A"!($P(IDS,"^",5)="C") S CONSULTDFN=IDS
;
;is consulting site known in the list and if site is Cerner enabled but not known
I CONSULTDFN'="" D
. ; if consulting site is known and it is NOT a Cerner enabled site
. I $P(CONSULTDFN,"^",5)'="C" D Q
.. S GMRCLINK=$O(GMRCLINK(0)) I 'GMRCLINK Q ; no link for that site
.. S GMRCLINK=GMRCLINK(GMRCLINK) I '$L(GMRCLINK) Q ;no link name
.. S RETURN="GMRC IFC SUBSC^"_GMRCLINK_U_STA Q ;MKN GMRC*3*154 added STA to RETURN
. ;
. ; if consulting site is known and it is a Cerner enabled site but patient unknown to Cerner
. I $P(CONSULTDFN,"^",5)="C",(CERNERID="") S RETURN=$$GETLINK(STA) Q
. ; if consulting site is known and it is a Cerner enabled site
. I $P(CONSULTDFN,"^",5)="C",(CERNERID'="") D
.. ; if Cerner enabled site AND Cerner knows patient set route to VDIF regional router
.. S RETURN=$$GETLINK(STA) ;MKN GMRC*3*154 added STA to RETURN
I CONSULTDFN="" D
. D LOGMSG^GMRCIUTL(GMRCDA,1,"",201)
. S RETURN=""
;
Q RETURN
;
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) ;
N CERNERID,CNT,CONSULTDFN,DGKEY,DGOUT,GMRCDFN,IDS,SITE,STA
S GMRCDFN=$P(^GMR(123,GMRCDA,0),U,2) I 'GMRCDFN Q
;
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
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 F S CNT=$O(DGOUT(CNT)) Q:'CNT S IDS=$G(DGOUT(CNT)) D
.I $P(IDS,"^",4)="200CRNR" I $P(IDS,"^",2)="PI" S CERNERID=IDS
.I $P(IDS,"^",4)=STA I $P(IDS,"^",2)="PI" I $P(IDS,"^",5)="A"!($P(IDS,"^",5)="C") S CONSULTDFN=IDS
. ; if consulting site is known and it is a Cerner enabled site but patient unknown to Cerner
. I $P(CONSULTDFN,"^",5)="C",(CERNERID="") D PROXYADD(GMRCDA,GMRCDFN,STA) Q
; if not known trigger Proxy Add Patient
I CONSULTDFN="" D PROXYADD(GMRCDA,GMRCDFN,STA)
Q
;
PROXYADD(GMRCDA,GMRCDFN,STA) ;
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")
I +CONSULTDFN=0 D LOGMSG^GMRCIUTL(GMRCDA,1,"",201)
Q
;
GETLINK(STA) ;
N GMRCLINK
D LINK^HLUTIL3(STA,.GMRCLINK,"I")
S GMRCLINK(1)=$$GET^XPAR("SYS","GMRC IFC REGIONAL ROUTER",1)
S GMRCLINK=$O(GMRCLINK(0)) I 'GMRCLINK Q "" ; no link for that site
S GMRCLINK=GMRCLINK(GMRCLINK) I '$L(GMRCLINK) Q "" ;no link name
Q "GMRC IFC SUBSC^"_GMRCLINK(1)_U_STA
;
;MKN GMRC*3.0*154 end mods
;
;MKN GMRC*3.0*184 - ISCERNER and CRNROBX added
;
ISCERNER(IEN) ;Is 'Add Comment' going to Cerner?
;Input:
; IEN = file #123
;Output:
; 1 = Prcessing complete
; 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
NOSND() ;Do not respond to the sent comment.
N GMRCL,GMRCZ,GMRCARRAY
S GMRCDQ=0
S GMRCL="",GMRCL=$O(^GMR(123,IEN,40,"B",GMRCL),-1) Q:GMRCL="" GMRCDQ
S GMRCZ="",GMRCZ=$O(^GMR(123,IEN,40,"B",GMRCL,""))
D GETS^DIQ(123.02,GMRCZ_","_IEN_",",.32,"I","GMRCARRAY")
S GMRCDQ=$G(GMRCARRAY(123.02,GMRCZ_","_IEN_",",.32,"I"),0)
Q GMRCDQ
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRCIEVT 16935 printed Apr 09, 2024@20:51:48 Page 2
GMRCIEVT ;SLC/JFR - process events and build HL7 message; 6/20/2021 09:23 ; Jun 02, 2022@09:21:37
+1 ;;3.0;CONSULT/REQUEST TRACKING;**22,28,31,121,154,184**;DEC 27, 1997;Build 22
+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 ;
+6 ;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^GMRCIEVT()
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
IF ACTYPE=2!(ACTYPE=1)
DO NW(IEN)
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) ;build new order message for IFC
+1 ; Input:
+2 ; GMRCDA = ien from file 123
+3 ;
+4 NEW HL,HLL,SEG,GMRC773,GMRCIQT,GMRCPD
+5 ;MKN GMRC*3.0*154 Check PT correlation and do proxy add if required
DO CHKCORR(GMRCDA)
+6 SET SEG=1
+7 KILL ^TMP("HLS",$JOB)
+8 DO INIT^HLFNC2("GMRC IFC ORM EVENT",.HL)
+9 ; if HL array can't be built, log it with an error
IF $GET(HL)
Begin DoDot:1
+10 ;MKN GMRC*3.0*154 GMRCACT to ACTN
DO LOGMSG^GMRCIUTL(GMRCDA,ACTN,,904)
End DoDot:1
QUIT
+11 ;build PID seg if not a local ICN
Begin DoDot:1
+12 NEW GMRCDFN
SET GMRCDFN=$PIECE(^GMR(123,+GMRCDA,0),U,2)
+13 IF '$GET(GMRCDFN)
SET GMRCIQT=1
QUIT
+14 IF $$GETICN^MPIF001(GMRCDFN)<1
SET GMRCIQT=1
QUIT
+15 IF $$IFLOCAL^MPIF001(GMRCDFN)
SET GMRCIQT=1
QUIT
+16 SET ^TMP("HLS",$JOB,SEG)=$$EN^VAFCPID(GMRCDFN,"1,2,3,4,5,7,8,19")
+17 ;
+18 ; If remote site is converted, enhance the PID segment. p184
+19 ;
+20 ;
IF $$CNVTD(GMRCDA)=1
SET ^TMP("HLS",$JOB,SEG)=$$ADD2PID^GMRCIUTL(^TMP("HLS",$JOB,SEG),GMRCDFN,$PIECE($GET(^GMR(123,GMRCDA,"CERNER")),U,3))
+21 ;
+22 SET SEG=SEG+1
+23 QUIT
End DoDot:1
IF $DATA(GMRCIQT)
DO NOMPI(GMRCDA,1)
QUIT
+24 ; get ORC for new ord
SET ^TMP("HLS",$JOB,SEG)=$$NWORC^GMRCISG1(GMRCDA)
+25 SET SEG=SEG+1
+26 ;get OBR segment
SET ^TMP("HLS",$JOB,SEG)=$$OBR^GMRCISG1(GMRCDA)
+27 ;
+28 ; If remote site is converted, enhance the OBR segment. p184
+29 ;
+30 ;
IF $$CNVTD(GMRCDA)=1
SET ^TMP("HLS",$JOB,SEG)=$$ADD2OBR^GMRCIUTL(^TMP("HLS",$JOB,SEG),GMRCDA)
+31 ;
+32 SET SEG=SEG+1
+33 ;build reason for request into OBX segment(s)
Begin DoDot:1
+34 KILL ^TMP("GMRCRFR",$JOB)
+35 DO OBXWP^GMRCISEG(GMRCDA,"NW",1,$NAME(^TMP("GMRCRFR",$JOB)))
+36 IF '$DATA(^TMP("GMRCRFR",$JOB))
QUIT
+37 NEW I
SET I=0
+38 FOR
SET I=$ORDER(^TMP("GMRCRFR",$JOB,I))
if 'I
QUIT
Begin DoDot:2
+39 SET ^TMP("HLS",$JOB,SEG)=^TMP("GMRCRFR",$JOB,I)
+40 SET SEG=SEG+1
End DoDot:2
+41 KILL ^TMP("GMRCRFR",$JOB)
+42 QUIT
End DoDot:1
+43 ;bl;154 preventing blank line for OBX
SET GMRCPD=$$OBXPD^GMRCISG1(GMRCDA)
+44 ; build prov DX in OBX
IF GMRCPD'=""
SET ^TMP("HLS",$JOB,SEG)=GMRCPD
+45 SET SEG=SEG+1
+46 ;always send local time zone
SET ^TMP("HLS",$JOB,SEG)=$$OBXTZ^GMRCISEG
+47 ;
+48 ;AV/MKN Add NTE segment to HL7 to send UCID file #123, field #80 *121*
+49 NEW SEP
+50 SET SEP=HL("FS")
+51 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
+52 ;AV/MKN End of NTE for UCID *121*
+53 ;
+54 ;log error
SET HLL("LINKS",1)=$$ROUTE(GMRCDA)
IF '$LENGTH(HLL("LINKS",1))
Begin DoDot:1
+55 ;MKN GMRC*3*154 '$$EXIST201
if '$$EXIST201^GMRCIEV1(IEN,ACTN)
DO LOGMSG^GMRCIUTL(IEN,ACTN,"",903)
End DoDot:1
QUIT
+56 ;MKN GMRC*3*154 Station coming back from $$ROUTE
SET HLP("SUBSCRIBER")="^^^^"_$PIECE(HLL("LINKS",1),U,3)
+57 ;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)
+58 NEW ERR
SET ERR=$SELECT($PIECE(GMRC773,U,2):904,1:"")
+59 DO LOGMSG^GMRCIUTL(GMRCDA,1,+GMRC773,ERR)
+60 QUIT
+61 ;
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 ;need to understanding their queuing
+8 NEW SITE,GMRCLINK,STA
+9 NEW DGKEY,DGOUT,CNT,IDS,CERNERID,CONSULTDFN,GMRCDFN,MPIDATA,RETURN,PATARR,X
+10 SET (RETURN,CERNERID,CONSULTDFN)=""
+11 ;no ROUTING FACILITY
SET SITE=$PIECE(^GMR(123,GMRCDA,0),U,23)
IF 'SITE
QUIT ""
+12 ;can't find station num for that site
SET STA=$$STA^XUAF4(SITE)
IF '$LENGTH(STA)
QUIT ""
+13 ;
+14 DO LINK^HLUTIL3(STA,.GMRCLINK,"I")
+15 ;
+16 ;WCJ; if no patient - should not happen
+17 SET GMRCDFN=$PIECE(^GMR(123,GMRCDA,0),U,2)
IF 'GMRCDFN
QUIT ""
+18 ;
+19 ;pull patient Correlation list
+20 SET DGKEY=GMRCDFN_U_"PI"_U_"USVHA"_U_$PIECE($$SITE^VASITE,"^",3)
+21 DO TFL^VAFCTFU2(.DGOUT,DGKEY)
+22 ;
+23 SET CNT=0
FOR
SET CNT=$ORDER(DGOUT(CNT))
if 'CNT
QUIT
SET IDS=$GET(DGOUT(CNT))
Begin DoDot:1
+24 IF $PIECE(IDS,"^",4)="200CRNR"
IF $PIECE(IDS,"^",2)="PI"
SET CERNERID=IDS
+25 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
+26 ;
+27 ;is consulting site known in the list and if site is Cerner enabled but not known
+28 IF CONSULTDFN'=""
Begin DoDot:1
+29 ; if consulting site is known and it is NOT a Cerner enabled site
+30 IF $PIECE(CONSULTDFN,"^",5)'="C"
Begin DoDot:2
+31 ; no link for that site
SET GMRCLINK=$ORDER(GMRCLINK(0))
IF 'GMRCLINK
QUIT
+32 ;no link name
SET GMRCLINK=GMRCLINK(GMRCLINK)
IF '$LENGTH(GMRCLINK)
QUIT
+33 ;MKN GMRC*3*154 added STA to RETURN
SET RETURN="GMRC IFC SUBSC^"_GMRCLINK_U_STA
QUIT
End DoDot:2
QUIT
+34 ;
+35 ; if consulting site is known and it is a Cerner enabled site but patient unknown to Cerner
+36 IF $PIECE(CONSULTDFN,"^",5)="C"
IF (CERNERID="")
SET RETURN=$$GETLINK(STA)
QUIT
+37 ; if consulting site is known and it is a Cerner enabled site
+38 IF $PIECE(CONSULTDFN,"^",5)="C"
IF (CERNERID'="")
Begin DoDot:2
+39 ; if Cerner enabled site AND Cerner knows patient set route to VDIF regional router
+40 ;MKN GMRC*3*154 added STA to RETURN
SET RETURN=$$GETLINK(STA)
End DoDot:2
End DoDot:1
+41 IF CONSULTDFN=""
Begin DoDot:1
+42 DO LOGMSG^GMRCIUTL(GMRCDA,1,"",201)
+43 SET RETURN=""
End DoDot:1
+44 ;
+45 QUIT RETURN
+46 ;
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 NEW CERNERID,CNT,CONSULTDFN,DGKEY,DGOUT,GMRCDFN,IDS,SITE,STA
+2 SET GMRCDFN=$PIECE(^GMR(123,GMRCDA,0),U,2)
IF 'GMRCDFN
QUIT
+3 ;
+4 ;no ROUTING FACILITY
SET SITE=$PIECE(^GMR(123,GMRCDA,0),U,23)
IF 'SITE
QUIT ""
+5 ;can't find station num for that site
SET STA=$$STA^XUAF4(SITE)
IF '$LENGTH(STA)
QUIT ""
+6 SET (CERNERID,CONSULTDFN)=""
+7 ;pull patient Correlation list
+8 SET DGKEY=GMRCDFN_U_"PI"_U_"USVHA"_U_$PIECE($$SITE^VASITE,"^",3)
+9 DO TFL^VAFCTFU2(.DGOUT,DGKEY)
+10 ;
+11 SET CNT=0
FOR
SET CNT=$ORDER(DGOUT(CNT))
if 'CNT
QUIT
SET IDS=$GET(DGOUT(CNT))
Begin DoDot:1
+12 IF $PIECE(IDS,"^",4)="200CRNR"
IF $PIECE(IDS,"^",2)="PI"
SET CERNERID=IDS
+13 IF $PIECE(IDS,"^",4)=STA
IF $PIECE(IDS,"^",2)="PI"
IF $PIECE(IDS,"^",5)="A"!($PIECE(IDS,"^",5)="C")
SET CONSULTDFN=IDS
+14 ; if consulting site is known and it is a Cerner enabled site but patient unknown to Cerner
+15 IF $PIECE(CONSULTDFN,"^",5)="C"
IF (CERNERID="")
DO PROXYADD(GMRCDA,GMRCDFN,STA)
QUIT
End DoDot:1
+16 ; if not known trigger Proxy Add Patient
+17 IF CONSULTDFN=""
DO PROXYADD(GMRCDA,GMRCDFN,STA)
+18 QUIT
+19 ;
PROXYADD(GMRCDA,GMRCDFN,STA) ;
+1 NEW CONSULTDFN,MPIDATA,PATARR
+2 SET CONSULTDFN=0
+3 DO GETPAT^MPIFRES(GMRCDFN,.PATARR)
+4 SET PATARR(1,"preferredFacilityNumber")=STA
+5 SET PATARR(1,"AddType")="ADDPREFTF"
+6 DO GETICN^MPIFXMLI(.MPIDATA,.PATARR)
IF +MPIDATA("ICN")>0
SET CONSULTDFN=+MPIDATA("ICN")
+7 IF +CONSULTDFN=0
DO LOGMSG^GMRCIUTL(GMRCDA,1,"",201)
+8 QUIT
+9 ;
GETLINK(STA) ;
+1 NEW GMRCLINK
+2 DO LINK^HLUTIL3(STA,.GMRCLINK,"I")
+3 SET GMRCLINK(1)=$$GET^XPAR("SYS","GMRC IFC REGIONAL ROUTER",1)
+4 ; no link for that site
SET GMRCLINK=$ORDER(GMRCLINK(0))
IF 'GMRCLINK
QUIT ""
+5 ;no link name
SET GMRCLINK=GMRCLINK(GMRCLINK)
IF '$LENGTH(GMRCLINK)
QUIT ""
+6 QUIT "GMRC IFC SUBSC^"_GMRCLINK(1)_U_STA
+7 ;
+8 ;MKN GMRC*3.0*154 end mods
+9 ;
+10 ;MKN GMRC*3.0*184 - ISCERNER and CRNROBX added
+11 ;
ISCERNER(IEN) ;Is 'Add Comment' going to Cerner?
+1 ;Input:
+2 ; IEN = file #123
+3 ;Output:
+4 ; 1 = Prcessing complete
+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
NOSND() ;Do not respond to the sent comment.
+1 NEW GMRCL,GMRCZ,GMRCARRAY
+2 SET GMRCDQ=0
+3 SET GMRCL=""
SET GMRCL=$ORDER(^GMR(123,IEN,40,"B",GMRCL),-1)
if GMRCL=""
QUIT GMRCDQ
+4 SET GMRCZ=""
SET GMRCZ=$ORDER(^GMR(123,IEN,40,"B",GMRCL,""))
+5 DO GETS^DIQ(123.02,GMRCZ_","_IEN_",",.32,"I","GMRCARRAY")
+6 SET GMRCDQ=$GET(GMRCARRAY(123.02,GMRCZ_","_IEN_",",.32,"I"),0)
+7 QUIT GMRCDQ
