GMRCIBKG ;SLC/JFR - IFC BACKGROUND ERROR PROCESSOR; 07/02/03 13:54
;;3.0;CONSULT/REQUEST TRACKING;**22,28,30,35,58,92,154**;DEC 27, 1997;Build 135
;;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
. ; 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRCIBKG 7073 printed Apr 09, 2024@20:52:37 Page 2
GMRCIBKG ;SLC/JFR - IFC BACKGROUND ERROR PROCESSOR; 07/02/03 13:54
+1 ;;3.0;CONSULT/REQUEST TRACKING;**22,28,30,35,58,92,154**;DEC 27, 1997;Build 135
+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 ; v-- wait at least 1 hour on all other errors
+20 IF $PIECE(GMRCLOG0,U)>GMRCTIM
QUIT
+21 ; v-- if incomplete activity is now the earliest, resend it
+22 IF $PIECE(GMRCLOG0,U,6)
IF $PIECE(GMRCLOG0,U,8)=902
Begin DoDot:2
+23 if $ORDER(^GMR(123.6,"AC",$PIECE(GMRCLOG0,U,4),$PIECE(GMRCLOG0,U,5)),-1)
QUIT
+24 DO DELALRT(GMRCLOG)
+25 ;re-send activity
DO TRIGR^GMRCIEVT($PIECE(GMRCLOG0,U,4),$PIECE(GMRCLOG0,U,5))
End DoDot:2
QUIT
+26 ; v-- delete complete entries after # in GMRC RETAIN IFC ACTIVITY DAYS
+27 IF '$PIECE(GMRCLOG0,U,6)
Begin DoDot:2
+28 NEW DIK,DA,GMRCRETN
+29 SET GMRCRETN=$$GET^XPAR("SYS","GMRC RETAIN IFC ACTIVITY DAYS",1)
+30 IF 'GMRCRETN
SET GMRCRETN=7
+31 ;don't delete
IF $PIECE(GMRCLOG0,U)>$$FMADD^XLFDT(GMRCTIM,(0-GMRCRETN))
QUIT
+32 SET DIK="^GMR(123.6,"
SET DA=GMRCLOG
+33 ;remove old completed entries
DO ^DIK
End DoDot:2
QUIT
+34 ;
+35 ; v-- resend unknown patient errors after 3 hours
+36 IF $PIECE(GMRCLOG0,U,8)=201
IF GMRCLOG0<$$FMADD^XLFDT($$NOW^XLFDT,,-1)
Begin DoDot:2
+37 NEW GMRCSND,GMRCPAR,DOW
+38 SET GMRCPAR=$$GET^XPAR("SYS","GMRC IFC SKIP WEEKEND RE-TRANS",1)
+39 SET DOW=$$DOW^XLFDT(DT,1)
+40 SET GMRCSND=$SELECT('GMRCPAR:1,(+DOW&(DOW<6)):1,1:0)
+41 ;re-send based on parameter and day of week
IF GMRCSND
Begin DoDot:3
+42 ;delete previous alerts on same transaction
DO DELALRT(GMRCLOG)
+43 DO TRIGR^GMRCIEVT($PIECE(GMRCLOG0,U,4),$PIECE(GMRCLOG0,U,5))
End DoDot:3
+44 IF '($PIECE(GMRCLOG0,U,7)#8)
IF GMRCSND
Begin DoDot:3
+45 ;alert CAC's about errors every 24 hrs.
+46 ;delete previous alerts on same transaction
DO DELALRT(GMRCLOG)
+47 ; alert CAC's to patient errors
DO SNDALRT^GMRCIERR(GMRCLOG,"C")
+48 ; send mail to remote CAC group
Begin DoDot:4
+49 NEW GMRCLNK,GMRCIQT,HL,HLECH,HLFS,HLQ,PID,DOM,STA,GMRCLNK,OBR
+50 DO INIT^HLFNC2("GMRC IFC ORM EVENT",.HL)
+51 ;build PID seg if nat'l ICN
Begin DoDot:5
+52 NEW GMRCDFN
SET GMRCDFN=$PIECE(^GMR(123,+$PIECE(GMRCLOG0,U,4),0),U,2)
+53 IF '$GET(GMRCDFN)
SET GMRCIQT=1
QUIT
+54 IF $$GETICN^MPIF001(GMRCDFN)<1
SET GMRCIQT=1
QUIT
+55 IF $$IFLOCAL^MPIF001(GMRCDFN)
SET GMRCIQT=1
QUIT
+56 SET PID=$$EN^VAFCPID(GMRCDFN,"1,2,3,4,5,7,8,19")
+57 SET PID=$PIECE(PID,"|",2,999)
End DoDot:5
IF $DATA(GMRCIQT)
QUIT
+58 DO LINK^HLUTIL3($PIECE(GMRCLOG0,U,2),.GMRCLNK)
+59 ;BL GMRC*3.0*154; Need to check if site has been converted to Cerner and if so route properly
+60 ; S:$$CNVTD^GMRCIEVT($P(GMRCLOG0,U,2)) GMRCLNK(1)=$$GET^XPAR("SYS","GMRC IFC REGIONAL ROUTER",1)
+61 ; S:$$CNVTD^GMRCIEVT($P(GMRCLOG0,U,4)) GMRCLNK(1)=$$GET^XPAR("SYS","GMRC IFC REGIONAL ROUTER",1)
+62 NEW CNVDT
+63 SET CNVDT=$$CNVTD^GMRCIEVT($PIECE(GMRCLOG0,U,4))
+64 IF CNVDT
Begin DoDot:5
+65 SET GMRCLNK(1)=$$GET^XPAR("SYS","GMRC IFC REGIONAL ROUTER",1)
+66 SET GMRCLNK=$$FIND1^DIC(870,,"EX",GMRCLNK(1))
End DoDot:5
+67 IF 'CNVDT
SET GMRCLNK=$ORDER(GMRCLNK(0))
+68 ;no link set up
IF 'GMRCLNK
QUIT
+69 SET DOM=$$GET1^DIQ(870,+GMRCLNK,.03)
+70 SET STA=$$STA^XUAF4($PIECE(GMRCLOG0,U,2))
+71 SET OBR=$EXTRACT($$OBR^GMRCISG1(+$PIECE(GMRCLOG0,U,4),+$PIECE(GMRCLOG0,U,5)),5,999)
+72 ;N DIV S DIV=STA,STA=+$$SITE^VASITE
+73 ;Changed to return correct station number
NEW DIV
SET DIV=STA
SET STA=+$PIECE($$SITE^VASITE,U,3)
+74 DO PTERRMSG^GMRCIERR(PID,STA,DOM,OBR)
End DoDot:4
End DoDot:3
End DoDot:2
QUIT
+75 ;
+76 ; v-- resend local ICN errors after 3 hours
+77 IF $PIECE(GMRCLOG0,U,8)=202
IF GMRCLOG0<$$FMADD^XLFDT($$NOW^XLFDT,,-3)
Begin DoDot:2
+78 ;re-send based on parameter and day of week
+79 NEW GMRCSND,GMRCPAR,DOW
+80 SET GMRCPAR=$$GET^XPAR("SYS","GMRC IFC SKIP WEEKEND RE-TRANS",1)
+81 SET DOW=$$DOW^XLFDT(DT,1)
+82 SET GMRCSND=$SELECT('GMRCPAR:1,(+DOW&(DOW<6)):1,1:0)
+83 ;don't re-send activity
IF 'GMRCSND
QUIT
+84 ;re-send activity
DO TRIGR^GMRCIEVT($PIECE(GMRCLOG0,U,4),$PIECE(GMRCLOG0,U,5))
+85 ;alert CAC's about errors every 24 hrs
IF '($PIECE(GMRCLOG0,U,7)#8)
Begin DoDot:3
+86 ;delete previous alerts on same transaction
DO DELALRT(GMRCLOG)
+87 ; alert CAC's to patient errors
DO SNDALRT^GMRCIERR(GMRCLOG,"C")
End DoDot:3
End DoDot:2
QUIT
+88 ; v-- re-process implementation errors
+89 ;I $P(GMRCLOG0,U,8)>300,$P(GMRCLOG0,U,8)<702 D Q
+90 IF $PIECE(GMRCLOG0,U,8)>300
IF $PIECE(GMRCLOG0,U,8)<704
Begin DoDot:2
+91 ;delete previous alerts on same transaction
DO DELALRT(GMRCLOG)
+92 ;re-send activity
DO TRIGR^GMRCIEVT($PIECE(GMRCLOG0,U,4),$PIECE(GMRCLOG0,U,5))
End DoDot:2
QUIT
+93 ; v-- if incomplete and no error, alert tech group
+94 IF '$PIECE(GMRCLOG0,U,8)!($PIECE(GMRCLOG0,U,8)>902)
Begin DoDot:2
+95 ;delete previous alerts on same transaction
DO DELALRT(GMRCLOG)
+96 DO SNDALRT^GMRCIERR(GMRCLOG,"T")
End DoDot:2
QUIT
+97 QUIT
End DoDot:1
+98 ;
+99 ; v-- set finish param
+100 DO EN^XPAR("SYS","GMRC IFC BACKGROUND FINISH",1,$$NOW^XLFDT)
+101 ; v-- start it again one hour after completing
+102 DO REQUEUE
+103 QUIT
+104 ;
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
