- 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 Jan 18, 2025@02:47:16 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