Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: GMRCIBKG

GMRCIBKG.m

Go to the documentation of this file. 
  1. GMRCIBKG ;SLC/JFR - IFC BACKGROUND ERROR PROCESSOR; 07/02/03 13:54
  1.  ;;3.0;CONSULT/REQUEST TRACKING;**22,28,30,35,58**;DEC 27, 1997;Build 4
  1.  ;;Per VHA Directive 2004-038, this routine should not be modified.
  1.  ;
  1.  ; This routine invokes IA# 3335
  1.  ;
  1. EN ;process file 123.6 and take action
  1.  ;Start background process
  1.  I $D(ZTQUEUED) S ZTREQ="@"
  1.  ;
  1.  ; OK to run?
  1.  I '$$GONOGO Q
  1.  ;
  1.  ; set start param to NOW and run
  1.  D EN^XPAR("SYS","GMRC IFC BACKGROUND START",1,$$NOW^XLFDT)
  1.  ;
  1.  N GMRCLOG,GMRCTIM,GMRCLOG0
  1.  S GMRCLOG=0
  1.  S GMRCTIM=$$FMADD^XLFDT($$NOW^XLFDT,,-1)
  1.  F  S GMRCLOG=$O(^GMR(123.6,GMRCLOG)) Q:'GMRCLOG  D
  1.  . S GMRCLOG0=$G(^GMR(123.6,GMRCLOG,0))
  1.  . ;
  1.  . ;  v-- resend if couldn't update file immediately
  1.  . I $P(GMRCLOG0,U,6),$P(GMRCLOG0,U,8)=901 D  Q
  1.  .. D TRIGR^GMRCIEVT($P(GMRCLOG0,U,4),$P(GMRCLOG0,U,5)) ;re-send activity
  1.  . ;  v-- wait at least 1 hour on all other errors
  1.  . I $P(GMRCLOG0,U)>GMRCTIM Q
  1.  . ;  v-- if incomplete activity is now the earliest, resend it
  1.  . I $P(GMRCLOG0,U,6),$P(GMRCLOG0,U,8)=902 D  Q
  1.  .. Q:$O(^GMR(123.6,"AC",$P(GMRCLOG0,U,4),$P(GMRCLOG0,U,5)),-1)
  1.  .. D DELALRT(GMRCLOG)
  1.  .. D TRIGR^GMRCIEVT($P(GMRCLOG0,U,4),$P(GMRCLOG0,U,5)) ;re-send activity
  1.  . ; v-- delete complete entries after # in GMRC RETAIN IFC ACTIVITY DAYS
  1.  . I '$P(GMRCLOG0,U,6) D  Q
  1.  .. N DIK,DA,GMRCRETN
  1.  .. S GMRCRETN=$$GET^XPAR("SYS","GMRC RETAIN IFC ACTIVITY DAYS",1)
  1.  .. I 'GMRCRETN S GMRCRETN=7
  1.  .. I $P(GMRCLOG0,U)>$$FMADD^XLFDT(GMRCTIM,(0-GMRCRETN)) Q  ;don't delete
  1.  .. S DIK="^GMR(123.6,",DA=GMRCLOG
  1.  .. D ^DIK ;remove old completed entries
  1.  . ;
  1.  . ;  v-- resend unknown patient errors after 3 hours
  1.  . I $P(GMRCLOG0,U,8)=201,GMRCLOG0<$$FMADD^XLFDT($$NOW^XLFDT,,-3) D  Q
  1.  .. N GMRCSND,GMRCPAR,DOW
  1.  .. S GMRCPAR=$$GET^XPAR("SYS","GMRC IFC SKIP WEEKEND RE-TRANS",1)
  1.  .. S DOW=$$DOW^XLFDT(DT,1)
  1.  .. S GMRCSND=$S('GMRCPAR:1,(+DOW&(DOW<6)):1,1:0)
  1.  .. I GMRCSND D  ;re-send based on parameter and day of week
  1.  ... D DELALRT(GMRCLOG) ;delete previous alerts on same transaction
  1.  ... D TRIGR^GMRCIEVT($P(GMRCLOG0,U,4),$P(GMRCLOG0,U,5))
  1.  .. I '($P(GMRCLOG0,U,7)#8),GMRCSND D
  1.  ... ;alert CAC's about errors every 24 hrs.
  1.  ... D DELALRT(GMRCLOG) ;delete previous alerts on same transaction
  1.  ... D SNDALRT^GMRCIERR(GMRCLOG,"C") ; alert CAC's to patient errors
  1.  ... D  ; send mail to remote CAC group
  1.  .... N GMRCLNK,GMRCIQT,HL,HLECH,HLFS,HLQ,PID,DOM,STA,GMRCLNK,OBR
  1.  .... D INIT^HLFNC2("GMRC IFC ORM EVENT",.HL)
  1.  .... D  I $D(GMRCIQT) Q  ;build PID seg if nat'l ICN
  1.  ..... N GMRCDFN S GMRCDFN=$P(^GMR(123,+$P(GMRCLOG0,U,4),0),U,2)
  1.  ..... I '$G(GMRCDFN) S GMRCIQT=1 Q
  1.  ..... I $$GETICN^MPIF001(GMRCDFN)<1 S GMRCIQT=1 Q
  1.  ..... I $$IFLOCAL^MPIF001(GMRCDFN) S GMRCIQT=1 Q
  1.  ..... S PID=$$EN^VAFCPID(GMRCDFN,"1,2,3,4,5,7,8,19")
  1.  ..... S PID=$P(PID,"|",2,999)
  1.  .... D LINK^HLUTIL3($P(GMRCLOG0,U,2),.GMRCLNK)
  1.  .... S GMRCLNK=$O(GMRCLNK(0)) I 'GMRCLNK Q  ;no link set up
  1.  .... S DOM=$$GET1^DIQ(870,+GMRCLNK,.03)
  1.  .... S STA=$$STA^XUAF4($P(GMRCLOG0,U,2))
  1.  .... S OBR=$E($$OBR^GMRCISG1(+$P(GMRCLOG0,U,4),+$P(GMRCLOG0,U,5)),5,999)
  1.  .... N DIV S DIV=STA,STA=+$$SITE^VASITE
  1.  .... D PTERRMSG^GMRCIERR(PID,STA,DOM,OBR)
  1.  . ;
  1.  . ;  v-- resend local ICN errors after 3 hours
  1.  . I $P(GMRCLOG0,U,8)=202,GMRCLOG0<$$FMADD^XLFDT($$NOW^XLFDT,,-3) D  Q
  1.  .. ;re-send based on parameter and day of week
  1.  .. N GMRCSND,GMRCPAR,DOW
  1.  .. S GMRCPAR=$$GET^XPAR("SYS","GMRC IFC SKIP WEEKEND RE-TRANS",1)
  1.  .. S DOW=$$DOW^XLFDT(DT,1)
  1.  .. S GMRCSND=$S('GMRCPAR:1,(+DOW&(DOW<6)):1,1:0)
  1.  .. I 'GMRCSND Q  ;don't re-send activity
  1.  .. D TRIGR^GMRCIEVT($P(GMRCLOG0,U,4),$P(GMRCLOG0,U,5)) ;re-send activity
  1.  .. I '($P(GMRCLOG0,U,7)#8) D  ;alert CAC's about errors every 24 hrs 
  1.  ... D DELALRT(GMRCLOG) ;delete previous alerts on same transaction
  1.  ... D SNDALRT^GMRCIERR(GMRCLOG,"C") ; alert CAC's to patient errors
  1.  . ;  v-- re-process implementation errors
  1.  . ;I $P(GMRCLOG0,U,8)>300,$P(GMRCLOG0,U,8)<702 D  Q
  1.  . I $P(GMRCLOG0,U,8)>300,$P(GMRCLOG0,U,8)<704 D  Q
  1.  .. D DELALRT(GMRCLOG) ;delete previous alerts on same transaction
  1.  .. D TRIGR^GMRCIEVT($P(GMRCLOG0,U,4),$P(GMRCLOG0,U,5)) ;re-send activity
  1.  . ;  v-- if incomplete and no error, alert tech group
  1.  . I '$P(GMRCLOG0,U,8)!($P(GMRCLOG0,U,8)>902) D  Q
  1.  .. D DELALRT(GMRCLOG) ;delete previous alerts on same transaction
  1.  .. D SNDALRT^GMRCIERR(GMRCLOG,"T")
  1.  . Q
  1.  ;
  1.  ;  v-- set finish param 
  1.  D EN^XPAR("SYS","GMRC IFC BACKGROUND FINISH",1,$$NOW^XLFDT)
  1.  ;  v-- start it again one hour after completing
  1.  D REQUEUE
  1.  Q
  1.  ;
  1. REQUEUE ;task job to start up again one hour after completing
  1.  N ZTRTN,ZTSK,ZTIO,ZTDESC,ZTDTH
  1.  S ZTDESC="IF Consults background error processor"
  1.  S ZTIO=""
  1.  S ZTRTN="EN^GMRCIBKG"
  1.  S ZTDTH=$$FMTH^XLFDT($$FMADD^XLFDT($$NOW^XLFDT,,1))
  1.  D ^%ZTLOAD
  1.  Q
  1. DELALRT(MSGLOG) ;delete obsolete alerts for an entry
  1.  ; Input:
  1.  ;   MSGLOG = ien from file 123.6
  1.  ;
  1.  N XQAID,XQAKILL
  1.  S XQAID="GMRCIFC,trans error,"_MSGLOG,XQAKILL=0
  1.  D DELETEA^XQALERT
  1.  Q
  1.  ;
  1. OVERDUE ; write message for alert to tell IRM job is overdue
  1.  W @IOF
  1.  W !,"The Inter-facility Consults background job is overdue."
  1.  W !,"This is likely due to an error while the job runs. It is suggested"
  1.  W !,"that you check the systems for errors. If the errors are resolved"
  1.  W !,"the background job will catch up and run normally. There is a "
  1.  W !,"remote possibility that the GMRC IFC BACKGROUND... parameters have"
  1.  W !,"been edited and are out of synch."
  1.  S XQAKILL=0
  1.  Q
  1.  ;
  1. GONOGO() ; determine if background job should run or not
  1.  ;Output: 
  1.  ;  1 = go ahead and run
  1.  ;  0 = don't run for some reason
  1.  N GMRCQT
  1.  S GMRCQT=1
  1.  D
  1.  . N GMRCBST,GMRCNOW,GMRCBFI
  1.  . S GMRCBST=$$GET^XPAR("SYS","GMRC IFC BACKGROUND START",1)
  1.  . I 'GMRCBST Q  ; has never run or needs to
  1.  . S GMRCNOW=$$NOW^XLFDT
  1.  . I GMRCBST>GMRCNOW S GMRCQT=0 Q  ;set to future date/time - don't run
  1.  . S GMRCBFI=$$GET^XPAR("SYS","GMRC IFC BACKGROUND FINISH",1)
  1.  . I $$FMDIFF^XLFDT(GMRCNOW,GMRCBFI,2)<3600,GMRCBFI>GMRCBST S GMRCQT=0 Q
  1.  . ;                 ^--ran < 1 hr ago
  1.  . I $$FMDIFF^XLFDT(GMRCBST,GMRCBFI,2)>4500 D  Q
  1.  .. ; >1.5 hrs and job not finishing for some reason, alert techies
  1.  .. N XQA,XQAMSG,XQAROU,XQAID,XQAKILL
  1.  .. S XQAID="GMRC IFC BKG",XQAKILL=0 D DELETEA^XQALERT
  1.  .. S XQA("G.IFC TECH ERRORS")=""
  1.  .. S XQAMSG="IFC Background job overdue."
  1.  .. S XQAID="GMRC IFC BKG"
  1.  .. S XQAROU="OVERDUE^GMRCIBKG"
  1.  .. D SETUP^XQALERT
  1.  .. Q
  1.  . Q
  1.  Q GMRCQT