GMRCIBKG ;SLC/JFR - IFC BACKGROUND ERROR PROCESSOR; Jan 09, 2025@09:43:28
;;3.0;CONSULT/REQUEST TRACKING;**22,28,30,35,58,92,154,189,201**;DEC 27, 1997;Build 7
;;Per VHA Directive 6402, this routine should not be modified.
;
; This routine invokes IA# 3335
;
EN ;process file 123.6 and take action
;Start background process
I $D(ZTQUEUED) S ZTREQ="@"
;
; OK to run?
I '$$GONOGO Q
;
; set start param to NOW and run
D EN^XPAR("SYS","GMRC IFC BACKGROUND START",1,$$NOW^XLFDT)
;
N GMRCLOG,GMRCTIM,GMRCLOG0
S GMRCLOG=0
S GMRCTIM=$$FMADD^XLFDT($$NOW^XLFDT,,-1)
F S GMRCLOG=$O(^GMR(123.6,GMRCLOG)) Q:'GMRCLOG D
. S GMRCLOG0=$G(^GMR(123.6,GMRCLOG,0))
. ;
. ; v-- resend if couldn't update file immediately
. I $P(GMRCLOG0,U,6),$P(GMRCLOG0,U,8)=901 D Q
.. D TRIGR^GMRCIEVT($P(GMRCLOG0,U,4),$P(GMRCLOG0,U,5)) ;re-send activity
. ;
. ; wait at least 10 minutes for 205 errors (Waiting for treating facility to update) - p189 wtc 6/18/2024
. ;
. I $P(GMRCLOG0,U,6),$P(GMRCLOG0,U,8)=205 D Q ;
.. ;
.. I $P(GMRCLOG0,U,1)<$$FMADD^XLFDT($$NOW^XLFDT,,-10/60) D TRIGR^GMRCIEVT($P(GMRCLOG0,U,4),$P(GMRCLOG0,U,5)) ;re-send activity
. ;
. ; wait a day for 203 errors (Patient not in Cerner) - p189 wtc 5/4/22
. ;
. I $P(GMRCLOG0,U,6),$P(GMRCLOG0,U,8)=203 D Q ;
.. ;
.. I $P(GMRCLOG0,U,1)<$$FMADD^XLFDT($$NOW^XLFDT,-1) D TRIGR^GMRCIEVT($P(GMRCLOG0,U,4),$P(GMRCLOG0,U,5)) ;re-send activity
. ;
. ; wait an hour for 204 errors (Waiting for IFC order to be processed in Cerner) - p201 wtc 12/1/23
. ;
. I $P(GMRCLOG0,U,6),$P(GMRCLOG0,U,8)=204 D Q ;
.. ;
.. I $P(GMRCLOG0,U,1)<$$FMADD^XLFDT($$NOW^XLFDT,,-1) D ;
... I $P(^GMR(123,$P(GMRCLOG0,U,4),0),U,22)'="" D TRIGR^GMRCIEVT($P(GMRCLOG0,U,4),$P(GMRCLOG0,U,5)) ;re-send activity
. ;
. ; wait a day for 206 errors (ICN missing from incoming order). P201 WTC 5/6/24
. ;
. I $P(GMRCLOG0,U,6),$P(GMRCLOG0,U,8)=206 D Q ;
.. ;
.. I $P(GMRCLOG0,U,1)'<$$FMADD^XLFDT($$NOW^XLFDT,-1) Q ;
.. I $P(GMRCLOG0,U,1)<$$FMADD^XLFDT($$NOW^XLFDT,-7) D Q ; Mark complete if not resolved in 7 days.
... ;
... ; Clear do not purge flag for incoming order.
... ;
... N MSGID,HLMTIENS S MSGID=$P(GMRCLOG0,U,3),HLMTIENS=$O(^HLMA("C",MSGID,0)) ;
... I $G(HLMTIENS) N RTNCODE S RTNCODE=$$SETPURG^HLUTIL(0) ;
... ;
... N DIE,DA,DR ;
... S DIE="^GMR(123.6,",DA=GMRCLOG,DR=".06///@" D ^DIE ;
.. ;
.. ; Determine of ICN has been entered for the patient. If so, insert into PID segment of HL7 message then re-process.
.. ;
.. N GMRCICN,IEN772,IEN773,MSGID,PID,N,EDIPI,DGKEY,DGOUT ;
.. S MSGID=$P(GMRCLOG0,U,3) Q:MSGID="" ;
.. S IEN773=$O(^HLMA("C",MSGID,0)) Q:'IEN773 ;
.. S IEN772=$P($G(^HLMA(IEN773,0)),U,1) Q:'IEN772 ;
.. ;
.. S PID="" F N=1:1 Q:'$D(^HL(772,IEN772,"IN",N,0)) I $P(^(0),"|",1)="PID" S PID=^(0) Q ;
.. Q:PID="" ;
.. S EDIPI=$P($P($P(PID,"|",4),"~",2),U,1),DGKEY=EDIPI_"^NI^USDOD^200DOD" D TFL^VAFCTFU2(.DGOUT,DGKEY) ;
.. S GMRCICN="" F N=1:1 Q:'$D(DGOUT(N)) I $P(DGOUT(N),U,2,5)="NI^USVHA^200M^A" S GMRCICN=$P(DGOUT(N),U,1) Q ;
.. Q:GMRCICN="" ;
.. S PID=$$ADDICN(PID,GMRCICN),^HL(772,IEN772,"IN",N,0)=PID ;
.. ;
.. N RTNCODE S RTNCODE=$$REPROC^HLUTIL(IEN773,"IN^GMRCIMSG") Q:RTNCODE<0 ;
.. ;
.. N DIE,DA,DR ;
.. S DIE="^GMR(123.6,",DA=GMRCLOG,DR=".06///@" D ^DIE ;
.. ;
.. ; Clear do not purge flag from incoming order.
.. ;
.. N HLMTIENS S HLMTIENS=IEN773,RTNCODE=$$SETPURG^HLUTIL(0) ;
. ;
. ; v-- wait at least 1 hour on all other errors
. I $P(GMRCLOG0,U)>GMRCTIM Q
. ; v-- if incomplete activity is now the earliest, resend it
. I $P(GMRCLOG0,U,6),$P(GMRCLOG0,U,8)=902 D Q
.. Q:$O(^GMR(123.6,"AC",$P(GMRCLOG0,U,4),$P(GMRCLOG0,U,5)),-1)
.. D DELALRT(GMRCLOG)
.. D TRIGR^GMRCIEVT($P(GMRCLOG0,U,4),$P(GMRCLOG0,U,5)) ;re-send activity
. ; v-- delete complete entries after # in GMRC RETAIN IFC ACTIVITY DAYS
. I '$P(GMRCLOG0,U,6) D Q
.. N DIK,DA,GMRCRETN
.. S GMRCRETN=$$GET^XPAR("SYS","GMRC RETAIN IFC ACTIVITY DAYS",1)
.. I 'GMRCRETN S GMRCRETN=7
.. I $P(GMRCLOG0,U)>$$FMADD^XLFDT(GMRCTIM,(0-GMRCRETN)) Q ;don't delete
.. S DIK="^GMR(123.6,",DA=GMRCLOG
.. D ^DIK ;remove old completed entries
. ;
. ; v-- resend unknown patient errors after 3 hours
. I $P(GMRCLOG0,U,8)=201,GMRCLOG0<$$FMADD^XLFDT($$NOW^XLFDT,,-1) D Q
.. N GMRCSND,GMRCPAR,DOW
.. S GMRCPAR=$$GET^XPAR("SYS","GMRC IFC SKIP WEEKEND RE-TRANS",1)
.. S DOW=$$DOW^XLFDT(DT,1)
.. S GMRCSND=$S('GMRCPAR:1,(+DOW&(DOW<6)):1,1:0)
.. I GMRCSND D ;re-send based on parameter and day of week
... D DELALRT(GMRCLOG) ;delete previous alerts on same transaction
... D TRIGR^GMRCIEVT($P(GMRCLOG0,U,4),$P(GMRCLOG0,U,5))
.. I '($P(GMRCLOG0,U,7)#8),GMRCSND D
... ;alert CAC's about errors every 24 hrs.
... D DELALRT(GMRCLOG) ;delete previous alerts on same transaction
... D SNDALRT^GMRCIERR(GMRCLOG,"C") ; alert CAC's to patient errors
... D ; send mail to remote CAC group
.... N GMRCLNK,GMRCIQT,HL,HLECH,HLFS,HLQ,PID,DOM,STA,GMRCLNK,OBR
.... D INIT^HLFNC2("GMRC IFC ORM EVENT",.HL)
.... D I $D(GMRCIQT) Q ;build PID seg if nat'l ICN
..... N GMRCDFN S GMRCDFN=$P(^GMR(123,+$P(GMRCLOG0,U,4),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 PID=$$EN^VAFCPID(GMRCDFN,"1,2,3,4,5,7,8,19")
..... S PID=$P(PID,"|",2,999)
.... D LINK^HLUTIL3($P(GMRCLOG0,U,2),.GMRCLNK)
.... ;BL GMRC*3.0*154; Need to check if site has been converted to Cerner and if so route properly
.... ; S:$$CNVTD^GMRCIEVT($P(GMRCLOG0,U,2)) GMRCLNK(1)=$$GET^XPAR("SYS","GMRC IFC REGIONAL ROUTER",1)
.... ; S:$$CNVTD^GMRCIEVT($P(GMRCLOG0,U,4)) GMRCLNK(1)=$$GET^XPAR("SYS","GMRC IFC REGIONAL ROUTER",1)
.... N CNVDT
.... S CNVDT=$$CNVTD^GMRCIEVT($P(GMRCLOG0,U,4))
.... I CNVDT D
..... S GMRCLNK(1)=$$GET^XPAR("SYS","GMRC IFC REGIONAL ROUTER",1)
..... S GMRCLNK=$$FIND1^DIC(870,,"EX",GMRCLNK(1))
.... I 'CNVDT S GMRCLNK=$O(GMRCLNK(0))
.... I 'GMRCLNK Q ;no link set up
.... S DOM=$$GET1^DIQ(870,+GMRCLNK,.03)
.... S STA=$$STA^XUAF4($P(GMRCLOG0,U,2))
.... S OBR=$E($$OBR^GMRCISG1(+$P(GMRCLOG0,U,4),+$P(GMRCLOG0,U,5)),5,999)
.... ;N DIV S DIV=STA,STA=+$$SITE^VASITE
.... N DIV S DIV=STA,STA=+$P($$SITE^VASITE,U,3) ;Changed to return correct station number
.... D PTERRMSG^GMRCIERR(PID,STA,DOM,OBR)
. ;
. ; v-- resend local ICN errors after 3 hours
. I $P(GMRCLOG0,U,8)=202,GMRCLOG0<$$FMADD^XLFDT($$NOW^XLFDT,,-3) D Q
.. ;re-send based on parameter and day of week
.. N GMRCSND,GMRCPAR,DOW
.. S GMRCPAR=$$GET^XPAR("SYS","GMRC IFC SKIP WEEKEND RE-TRANS",1)
.. S DOW=$$DOW^XLFDT(DT,1)
.. S GMRCSND=$S('GMRCPAR:1,(+DOW&(DOW<6)):1,1:0)
.. I 'GMRCSND Q ;don't re-send activity
.. D TRIGR^GMRCIEVT($P(GMRCLOG0,U,4),$P(GMRCLOG0,U,5)) ;re-send activity
.. I '($P(GMRCLOG0,U,7)#8) D ;alert CAC's about errors every 24 hrs
... D DELALRT(GMRCLOG) ;delete previous alerts on same transaction
... D SNDALRT^GMRCIERR(GMRCLOG,"C") ; alert CAC's to patient errors
. ; v-- re-process implementation errors
. ;I $P(GMRCLOG0,U,8)>300,$P(GMRCLOG0,U,8)<702 D Q
. I $P(GMRCLOG0,U,8)>300,$P(GMRCLOG0,U,8)<704 D Q
.. D DELALRT(GMRCLOG) ;delete previous alerts on same transaction
.. D TRIGR^GMRCIEVT($P(GMRCLOG0,U,4),$P(GMRCLOG0,U,5)) ;re-send activity
. ; v-- if incomplete and no error, alert tech group
. I '$P(GMRCLOG0,U,8)!($P(GMRCLOG0,U,8)>902) D Q
.. D DELALRT(GMRCLOG) ;delete previous alerts on same transaction
.. D SNDALRT^GMRCIERR(GMRCLOG,"T")
. Q
;
; v-- set finish param
D EN^XPAR("SYS","GMRC IFC BACKGROUND FINISH",1,$$NOW^XLFDT)
; v-- start it again one hour after completing
D REQUEUE
Q
;
REQUEUE ;task job to start up again one hour after completing
N ZTRTN,ZTSK,ZTIO,ZTDESC,ZTDTH
S ZTDESC="IF Consults background error processor"
S ZTIO=""
S ZTRTN="EN^GMRCIBKG"
S ZTDTH=$$FMTH^XLFDT($$FMADD^XLFDT($$NOW^XLFDT,,1))
D ^%ZTLOAD
Q
DELALRT(MSGLOG) ;delete obsolete alerts for an entry
; Input:
; MSGLOG = ien from file 123.6
;
N XQAID,XQAKILL
S XQAID="GMRCIFC,trans error,"_MSGLOG,XQAKILL=0
D DELETEA^XQALERT
Q
;
OVERDUE ; write message for alert to tell IRM job is overdue
W @IOF
W !,"The Inter-facility Consults background job is overdue."
W !,"This is likely due to an error while the job runs. It is suggested"
W !,"that you check the systems for errors. If the errors are resolved"
W !,"the background job will catch up and run normally. There is a "
W !,"remote possibility that the GMRC IFC BACKGROUND... parameters have"
W !,"been edited and are out of synch."
S XQAKILL=0
Q
;
GONOGO() ; determine if background job should run or not
;Output:
; 1 = go ahead and run
; 0 = don't run for some reason
N GMRCQT
S GMRCQT=1
D
. N GMRCBST,GMRCNOW,GMRCBFI
. S GMRCBST=$$GET^XPAR("SYS","GMRC IFC BACKGROUND START",1)
. I 'GMRCBST Q ; has never run or needs to
. S GMRCNOW=$$NOW^XLFDT
. I GMRCBST>GMRCNOW S GMRCQT=0 Q ;set to future date/time - don't run
. S GMRCBFI=$$GET^XPAR("SYS","GMRC IFC BACKGROUND FINISH",1)
. I $$FMDIFF^XLFDT(GMRCNOW,GMRCBFI,2)<3600,GMRCBFI>GMRCBST S GMRCQT=0 Q
. ; ^--ran < 1 hr ago
. I $$FMDIFF^XLFDT(GMRCBST,GMRCBFI,2)>4500 D Q
.. ; >1.5 hrs and job not finishing for some reason, alert techies
.. N XQA,XQAMSG,XQAROU,XQAID,XQAKILL
.. S XQAID="GMRC IFC BKG",XQAKILL=0 D DELETEA^XQALERT
.. S XQA("G.IFC TECH ERRORS")=""
.. S XQAMSG="IFC Background job overdue."
.. S XQAID="GMRC IFC BKG"
.. S XQAROU="OVERDUE^GMRCIBKG"
.. D SETUP^XQALERT
.. Q
. Q
Q GMRCQT
;
ADDICN(PID,ICN) ;
;
; Insert ICN into PID-3 and ICN sub-field into PID-4.
;
N X ;
S X=$P(PID,"|",4),X=ICN_U_U_U_"ICN"_U_"VETID"_X,$P(PID,"|",3)=ICN,$P(PID,"|",4)=X ;
Q PID ;
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRCIBKG 9915 printed Aug 26, 2025@22:01:43 Page 2
GMRCIBKG ;SLC/JFR - IFC BACKGROUND ERROR PROCESSOR; Jan 09, 2025@09:43:28
+1 ;;3.0;CONSULT/REQUEST TRACKING;**22,28,30,35,58,92,154,189,201**;DEC 27, 1997;Build 7
+2 ;;Per VHA Directive 6402, this routine should not be modified.
+3 ;
+4 ; This routine invokes IA# 3335
+5 ;
EN ;process file 123.6 and take action
+1 ;Start background process
+2 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+3 ;
+4 ; OK to run?
+5 IF '$$GONOGO
QUIT
+6 ;
+7 ; set start param to NOW and run
+8 DO EN^XPAR("SYS","GMRC IFC BACKGROUND START",1,$$NOW^XLFDT)
+9 ;
+10 NEW GMRCLOG,GMRCTIM,GMRCLOG0
+11 SET GMRCLOG=0
+12 SET GMRCTIM=$$FMADD^XLFDT($$NOW^XLFDT,,-1)
+13 FOR
SET GMRCLOG=$ORDER(^GMR(123.6,GMRCLOG))
if 'GMRCLOG
QUIT
Begin DoDot:1
+14 SET GMRCLOG0=$GET(^GMR(123.6,GMRCLOG,0))
+15 ;
+16 ; v-- resend if couldn't update file immediately
+17 IF $PIECE(GMRCLOG0,U,6)
IF $PIECE(GMRCLOG0,U,8)=901
Begin DoDot:2
+18 ;re-send activity
DO TRIGR^GMRCIEVT($PIECE(GMRCLOG0,U,4),$PIECE(GMRCLOG0,U,5))
End DoDot:2
QUIT
+19 ;
+20 ; wait at least 10 minutes for 205 errors (Waiting for treating facility to update) - p189 wtc 6/18/2024
+21 ;
+22 ;
IF $PIECE(GMRCLOG0,U,6)
IF $PIECE(GMRCLOG0,U,8)=205
Begin DoDot:2
+23 ;
+24 ;re-send activity
IF $PIECE(GMRCLOG0,U,1)<$$FMADD^XLFDT($$NOW^XLFDT,,-10/60)
DO TRIGR^GMRCIEVT($PIECE(GMRCLOG0,U,4),$PIECE(GMRCLOG0,U,5))
End DoDot:2
QUIT
+25 ;
+26 ; wait a day for 203 errors (Patient not in Cerner) - p189 wtc 5/4/22
+27 ;
+28 ;
IF $PIECE(GMRCLOG0,U,6)
IF $PIECE(GMRCLOG0,U,8)=203
Begin DoDot:2
+29 ;
+30 ;re-send activity
IF $PIECE(GMRCLOG0,U,1)<$$FMADD^XLFDT($$NOW^XLFDT,-1)
DO TRIGR^GMRCIEVT($PIECE(GMRCLOG0,U,4),$PIECE(GMRCLOG0,U,5))
End DoDot:2
QUIT
+31 ;
+32 ; wait an hour for 204 errors (Waiting for IFC order to be processed in Cerner) - p201 wtc 12/1/23
+33 ;
+34 ;
IF $PIECE(GMRCLOG0,U,6)
IF $PIECE(GMRCLOG0,U,8)=204
Begin DoDot:2
+35 ;
+36 ;
IF $PIECE(GMRCLOG0,U,1)<$$FMADD^XLFDT($$NOW^XLFDT,,-1)
Begin DoDot:3
+37 ;re-send activity
IF $PIECE(^GMR(123,$PIECE(GMRCLOG0,U,4),0),U,22)'=""
DO TRIGR^GMRCIEVT($PIECE(GMRCLOG0,U,4),$PIECE(GMRCLOG0,U,5))
End DoDot:3
End DoDot:2
QUIT
+38 ;
+39 ; wait a day for 206 errors (ICN missing from incoming order). P201 WTC 5/6/24
+40 ;
+41 ;
IF $PIECE(GMRCLOG0,U,6)
IF $PIECE(GMRCLOG0,U,8)=206
Begin DoDot:2
+42 ;
+43 ;
IF $PIECE(GMRCLOG0,U,1)'<$$FMADD^XLFDT($$NOW^XLFDT,-1)
QUIT
+44 ; Mark complete if not resolved in 7 days.
IF $PIECE(GMRCLOG0,U,1)<$$FMADD^XLFDT($$NOW^XLFDT,-7)
Begin DoDot:3
+45 ;
+46 ; Clear do not purge flag for incoming order.
+47 ;
+48 ;
NEW MSGID,HLMTIENS
SET MSGID=$PIECE(GMRCLOG0,U,3)
SET HLMTIENS=$ORDER(^HLMA("C",MSGID,0))
+49 ;
IF $GET(HLMTIENS)
NEW RTNCODE
SET RTNCODE=$$SETPURG^HLUTIL(0)
+50 ;
+51 ;
NEW DIE,DA,DR
+52 ;
SET DIE="^GMR(123.6,"
SET DA=GMRCLOG
SET DR=".06///@"
DO ^DIE
End DoDot:3
QUIT
+53 ;
+54 ; Determine of ICN has been entered for the patient. If so, insert into PID segment of HL7 message then re-process.
+55 ;
+56 ;
NEW GMRCICN,IEN772,IEN773,MSGID,PID,N,EDIPI,DGKEY,DGOUT
+57 ;
SET MSGID=$PIECE(GMRCLOG0,U,3)
if MSGID=""
QUIT
+58 ;
SET IEN773=$ORDER(^HLMA("C",MSGID,0))
if 'IEN773
QUIT
+59 ;
SET IEN772=$PIECE($GET(^HLMA(IEN773,0)),U,1)
if 'IEN772
QUIT
+60 ;
+61 ;
SET PID=""
FOR N=1:1
if '$DATA(^HL(772,IEN772,"IN",N,0))
QUIT
IF $PIECE(^(0),"|",1)="PID"
SET PID=^(0)
QUIT
+62 ;
if PID=""
QUIT
+63 ;
SET EDIPI=$PIECE($PIECE($PIECE(PID,"|",4),"~",2),U,1)
SET DGKEY=EDIPI_"^NI^USDOD^200DOD"
DO TFL^VAFCTFU2(.DGOUT,DGKEY)
+64 ;
SET GMRCICN=""
FOR N=1:1
if '$DATA(DGOUT(N))
QUIT
IF $PIECE(DGOUT(N),U,2,5)="NI^USVHA^200M^A"
SET GMRCICN=$PIECE(DGOUT(N),U,1)
QUIT
+65 ;
if GMRCICN=""
QUIT
+66 ;
SET PID=$$ADDICN(PID,GMRCICN)
SET ^HL(772,IEN772,"IN",N,0)=PID
+67 ;
+68 ;
NEW RTNCODE
SET RTNCODE=$$REPROC^HLUTIL(IEN773,"IN^GMRCIMSG")
if RTNCODE<0
QUIT
+69 ;
+70 ;
NEW DIE,DA,DR
+71 ;
SET DIE="^GMR(123.6,"
SET DA=GMRCLOG
SET DR=".06///@"
DO ^DIE
+72 ;
+73 ; Clear do not purge flag from incoming order.
+74 ;
+75 ;
NEW HLMTIENS
SET HLMTIENS=IEN773
SET RTNCODE=$$SETPURG^HLUTIL(0)
End DoDot:2
QUIT
+76 ;
+77 ; v-- wait at least 1 hour on all other errors
+78 IF $PIECE(GMRCLOG0,U)>GMRCTIM
QUIT
+79 ; v-- if incomplete activity is now the earliest, resend it
+80 IF $PIECE(GMRCLOG0,U,6)
IF $PIECE(GMRCLOG0,U,8)=902
Begin DoDot:2
+81 if $ORDER(^GMR(123.6,"AC",$PIECE(GMRCLOG0,U,4),$PIECE(GMRCLOG0,U,5)),-1)
QUIT
+82 DO DELALRT(GMRCLOG)
+83 ;re-send activity
DO TRIGR^GMRCIEVT($PIECE(GMRCLOG0,U,4),$PIECE(GMRCLOG0,U,5))
End DoDot:2
QUIT
+84 ; v-- delete complete entries after # in GMRC RETAIN IFC ACTIVITY DAYS
+85 IF '$PIECE(GMRCLOG0,U,6)
Begin DoDot:2
+86 NEW DIK,DA,GMRCRETN
+87 SET GMRCRETN=$$GET^XPAR("SYS","GMRC RETAIN IFC ACTIVITY DAYS",1)
+88 IF 'GMRCRETN
SET GMRCRETN=7
+89 ;don't delete
IF $PIECE(GMRCLOG0,U)>$$FMADD^XLFDT(GMRCTIM,(0-GMRCRETN))
QUIT
+90 SET DIK="^GMR(123.6,"
SET DA=GMRCLOG
+91 ;remove old completed entries
DO ^DIK
End DoDot:2
QUIT
+92 ;
+93 ; v-- resend unknown patient errors after 3 hours
+94 IF $PIECE(GMRCLOG0,U,8)=201
IF GMRCLOG0<$$FMADD^XLFDT($$NOW^XLFDT,,-1)
Begin DoDot:2
+95 NEW GMRCSND,GMRCPAR,DOW
+96 SET GMRCPAR=$$GET^XPAR("SYS","GMRC IFC SKIP WEEKEND RE-TRANS",1)
+97 SET DOW=$$DOW^XLFDT(DT,1)
+98 SET GMRCSND=$SELECT('GMRCPAR:1,(+DOW&(DOW<6)):1,1:0)
+99 ;re-send based on parameter and day of week
IF GMRCSND
Begin DoDot:3
+100 ;delete previous alerts on same transaction
DO DELALRT(GMRCLOG)
+101 DO TRIGR^GMRCIEVT($PIECE(GMRCLOG0,U,4),$PIECE(GMRCLOG0,U,5))
End DoDot:3
+102 IF '($PIECE(GMRCLOG0,U,7)#8)
IF GMRCSND
Begin DoDot:3
+103 ;alert CAC's about errors every 24 hrs.
+104 ;delete previous alerts on same transaction
DO DELALRT(GMRCLOG)
+105 ; alert CAC's to patient errors
DO SNDALRT^GMRCIERR(GMRCLOG,"C")
+106 ; send mail to remote CAC group
Begin DoDot:4
+107 NEW GMRCLNK,GMRCIQT,HL,HLECH,HLFS,HLQ,PID,DOM,STA,GMRCLNK,OBR
+108 DO INIT^HLFNC2("GMRC IFC ORM EVENT",.HL)
+109 ;build PID seg if nat'l ICN
Begin DoDot:5
+110 NEW GMRCDFN
SET GMRCDFN=$PIECE(^GMR(123,+$PIECE(GMRCLOG0,U,4),0),U,2)
+111 IF '$GET(GMRCDFN)
SET GMRCIQT=1
QUIT
+112 IF $$GETICN^MPIF001(GMRCDFN)<1
SET GMRCIQT=1
QUIT
+113 IF $$IFLOCAL^MPIF001(GMRCDFN)
SET GMRCIQT=1
QUIT
+114 SET PID=$$EN^VAFCPID(GMRCDFN,"1,2,3,4,5,7,8,19")
+115 SET PID=$PIECE(PID,"|",2,999)
End DoDot:5
IF $DATA(GMRCIQT)
QUIT
+116 DO LINK^HLUTIL3($PIECE(GMRCLOG0,U,2),.GMRCLNK)
+117 ;BL GMRC*3.0*154; Need to check if site has been converted to Cerner and if so route properly
+118 ; S:$$CNVTD^GMRCIEVT($P(GMRCLOG0,U,2)) GMRCLNK(1)=$$GET^XPAR("SYS","GMRC IFC REGIONAL ROUTER",1)
+119 ; S:$$CNVTD^GMRCIEVT($P(GMRCLOG0,U,4)) GMRCLNK(1)=$$GET^XPAR("SYS","GMRC IFC REGIONAL ROUTER",1)
+120 NEW CNVDT
+121 SET CNVDT=$$CNVTD^GMRCIEVT($PIECE(GMRCLOG0,U,4))
+122 IF CNVDT
Begin DoDot:5
+123 SET GMRCLNK(1)=$$GET^XPAR("SYS","GMRC IFC REGIONAL ROUTER",1)
+124 SET GMRCLNK=$$FIND1^DIC(870,,"EX",GMRCLNK(1))
End DoDot:5
+125 IF 'CNVDT
SET GMRCLNK=$ORDER(GMRCLNK(0))
+126 ;no link set up
IF 'GMRCLNK
QUIT
+127 SET DOM=$$GET1^DIQ(870,+GMRCLNK,.03)
+128 SET STA=$$STA^XUAF4($PIECE(GMRCLOG0,U,2))
+129 SET OBR=$EXTRACT($$OBR^GMRCISG1(+$PIECE(GMRCLOG0,U,4),+$PIECE(GMRCLOG0,U,5)),5,999)
+130 ;N DIV S DIV=STA,STA=+$$SITE^VASITE
+131 ;Changed to return correct station number
NEW DIV
SET DIV=STA
SET STA=+$PIECE($$SITE^VASITE,U,3)
+132 DO PTERRMSG^GMRCIERR(PID,STA,DOM,OBR)
End DoDot:4
End DoDot:3
End DoDot:2
QUIT
+133 ;
+134 ; v-- resend local ICN errors after 3 hours
+135 IF $PIECE(GMRCLOG0,U,8)=202
IF GMRCLOG0<$$FMADD^XLFDT($$NOW^XLFDT,,-3)
Begin DoDot:2
+136 ;re-send based on parameter and day of week
+137 NEW GMRCSND,GMRCPAR,DOW
+138 SET GMRCPAR=$$GET^XPAR("SYS","GMRC IFC SKIP WEEKEND RE-TRANS",1)
+139 SET DOW=$$DOW^XLFDT(DT,1)
+140 SET GMRCSND=$SELECT('GMRCPAR:1,(+DOW&(DOW<6)):1,1:0)
+141 ;don't re-send activity
IF 'GMRCSND
QUIT
+142 ;re-send activity
DO TRIGR^GMRCIEVT($PIECE(GMRCLOG0,U,4),$PIECE(GMRCLOG0,U,5))
+143 ;alert CAC's about errors every 24 hrs
IF '($PIECE(GMRCLOG0,U,7)#8)
Begin DoDot:3
+144 ;delete previous alerts on same transaction
DO DELALRT(GMRCLOG)
+145 ; alert CAC's to patient errors
DO SNDALRT^GMRCIERR(GMRCLOG,"C")
End DoDot:3
End DoDot:2
QUIT
+146 ; v-- re-process implementation errors
+147 ;I $P(GMRCLOG0,U,8)>300,$P(GMRCLOG0,U,8)<702 D Q
+148 IF $PIECE(GMRCLOG0,U,8)>300
IF $PIECE(GMRCLOG0,U,8)<704
Begin DoDot:2
+149 ;delete previous alerts on same transaction
DO DELALRT(GMRCLOG)
+150 ;re-send activity
DO TRIGR^GMRCIEVT($PIECE(GMRCLOG0,U,4),$PIECE(GMRCLOG0,U,5))
End DoDot:2
QUIT
+151 ; v-- if incomplete and no error, alert tech group
+152 IF '$PIECE(GMRCLOG0,U,8)!($PIECE(GMRCLOG0,U,8)>902)
Begin DoDot:2
+153 ;delete previous alerts on same transaction
DO DELALRT(GMRCLOG)
+154 DO SNDALRT^GMRCIERR(GMRCLOG,"T")
End DoDot:2
QUIT
+155 QUIT
End DoDot:1
+156 ;
+157 ; v-- set finish param
+158 DO EN^XPAR("SYS","GMRC IFC BACKGROUND FINISH",1,$$NOW^XLFDT)
+159 ; v-- start it again one hour after completing
+160 DO REQUEUE
+161 QUIT
+162 ;
REQUEUE ;task job to start up again one hour after completing
+1 NEW ZTRTN,ZTSK,ZTIO,ZTDESC,ZTDTH
+2 SET ZTDESC="IF Consults background error processor"
+3 SET ZTIO=""
+4 SET ZTRTN="EN^GMRCIBKG"
+5 SET ZTDTH=$$FMTH^XLFDT($$FMADD^XLFDT($$NOW^XLFDT,,1))
+6 DO ^%ZTLOAD
+7 QUIT
DELALRT(MSGLOG) ;delete obsolete alerts for an entry
+1 ; Input:
+2 ; MSGLOG = ien from file 123.6
+3 ;
+4 NEW XQAID,XQAKILL
+5 SET XQAID="GMRCIFC,trans error,"_MSGLOG
SET XQAKILL=0
+6 DO DELETEA^XQALERT
+7 QUIT
+8 ;
OVERDUE ; write message for alert to tell IRM job is overdue
+1 WRITE @IOF
+2 WRITE !,"The Inter-facility Consults background job is overdue."
+3 WRITE !,"This is likely due to an error while the job runs. It is suggested"
+4 WRITE !,"that you check the systems for errors. If the errors are resolved"
+5 WRITE !,"the background job will catch up and run normally. There is a "
+6 WRITE !,"remote possibility that the GMRC IFC BACKGROUND... parameters have"
+7 WRITE !,"been edited and are out of synch."
+8 SET XQAKILL=0
+9 QUIT
+10 ;
GONOGO() ; determine if background job should run or not
+1 ;Output:
+2 ; 1 = go ahead and run
+3 ; 0 = don't run for some reason
+4 NEW GMRCQT
+5 SET GMRCQT=1
+6 Begin DoDot:1
+7 NEW GMRCBST,GMRCNOW,GMRCBFI
+8 SET GMRCBST=$$GET^XPAR("SYS","GMRC IFC BACKGROUND START",1)
+9 ; has never run or needs to
IF 'GMRCBST
QUIT
+10 SET GMRCNOW=$$NOW^XLFDT
+11 ;set to future date/time - don't run
IF GMRCBST>GMRCNOW
SET GMRCQT=0
QUIT
+12 SET GMRCBFI=$$GET^XPAR("SYS","GMRC IFC BACKGROUND FINISH",1)
+13 IF $$FMDIFF^XLFDT(GMRCNOW,GMRCBFI,2)<3600
IF GMRCBFI>GMRCBST
SET GMRCQT=0
QUIT
+14 ; ^--ran < 1 hr ago
+15 IF $$FMDIFF^XLFDT(GMRCBST,GMRCBFI,2)>4500
Begin DoDot:2
+16 ; >1.5 hrs and job not finishing for some reason, alert techies
+17 NEW XQA,XQAMSG,XQAROU,XQAID,XQAKILL
+18 SET XQAID="GMRC IFC BKG"
SET XQAKILL=0
DO DELETEA^XQALERT
+19 SET XQA("G.IFC TECH ERRORS")=""
+20 SET XQAMSG="IFC Background job overdue."
+21 SET XQAID="GMRC IFC BKG"
+22 SET XQAROU="OVERDUE^GMRCIBKG"
+23 DO SETUP^XQALERT
+24 QUIT
End DoDot:2
QUIT
+25 QUIT
End DoDot:1
+26 QUIT GMRCQT
+27 ;
ADDICN(PID,ICN) ;
+1 ;
+2 ; Insert ICN into PID-3 and ICN sub-field into PID-4.
+3 ;
+4 ;
NEW X
+5 ;
SET X=$PIECE(PID,"|",4)
SET X=ICN_U_U_U_"ICN"_U_"VETID"_X
SET $PIECE(PID,"|",3)=ICN
SET $PIECE(PID,"|",4)=X
+6 ;
QUIT PID
+7 ;
