XQALSUR2 ;FO-OAK.SEA/JLI-Continuation of alert surrogate processing ; September 6, 2023@14:28
;;8.0;KERNEL;**366,513,602,690,730,754,790**;Jul 10, 1995;Build 2
;Per VHA VA Directive 6402, this routine should not be modified
Q
; added to handle adjustment for manual or Fileman editing of surrogate on top zero node
CHEKSUBS(XQAUSER) ;
N XQA0,XQASTR1,XQANOW,XQB0,XQB1
S XQANOW=$$NOW^XLFDT()
S XQA0=$G(^XTV(8992,XQAUSER,0)) I $P(XQA0,U,2)>0 D
. N XQAFDA,XQAIEN,XQADA
. S XQASTR1=$P(XQA0,U,3) S:XQASTR1'>0 XQASTR1=XQANOW,XQAFDA(8992,XQAUSER_",",.03)=XQASTR1 D
. . S XQADA=0 F S XQADA=$O(^XTV(8992,XQAUSER,2,"B",XQASTR1,XQADA)) Q:XQADA'>0 D Q:$P($G(^XTV(8992,XQAUSER,2,XQADA,0)),U,2)=$P(XQA0,U,2) ; p754
. . . K:'$D(^XTV(8992,XQAUSER,2,XQADA,0)) ^XTV(8992,XQAUSER,2,"B",XQASTR1,XQADA) ;p754 somebody removed surr by gbl kill, cleanup
. . S XQAIEN=$S(XQADA>0:XQADA,1:"+1")_","_XQAUSER_"," S XQAFDA(8992.02,XQAIEN,.01)=XQASTR1
. . S XQAFDA(8992.02,XQAIEN,.02)=$P(XQA0,U,2) S:$P(XQA0,U,4)>0 XQAFDA(8992.02,XQAIEN,.03)=$P(XQA0,U,4)
. . D:XQADA'>0 UPDATE^DIE("","XQAFDA")
. . D:XQADA>0 FILE^DIE("","XQAFDA")
. . Q
. Q
Q
;
CHKCRIT(ZERONODE) ;EXTRINSIC - check for critical indication for alert
; ZERONODE - input - Value for zero node for alert data
; RETURN VALUE - 1 if the alert is indicated as critical
; 0 otherwise
N RESULT,IEN
S RESULT=0
F IEN=0:0 S IEN=$O(^XTV(8992.3,IEN)) Q:IEN'>0 D Q:RESULT
. N IENS,RES,MSG,CRITTEXT,PKGID,ALERTTXT
. S IENS=IEN_","
. D GETS^DIQ(8992.3,IENS,".01:.02",,"RES","MSG")
. S CRITTEXT=$$UP^XLFSTR(RES(8992.3,IENS,.01)),PKGID=$$UP^XLFSTR(RES(8992.3,IENS,.02))
. I PKGID'="",$$UP^XLFSTR($P(ZERONODE,U,2))'[PKGID Q
. S ALERTTXT=$$UP^XLFSTR($P(ZERONODE,U,3))
. I ALERTTXT[CRITTEXT,ALERTTXT'["NOT "_CRITTEXT,ALERTTXT'["NON "_CRITTEXT S RESULT=1 ;;XU*8*690 - Added check for "NON" critical text
Q RESULT
;
CLEANUP(XQAUSER) ;SR. - clean up expired surrogate info
N XQAI,XQARETD,XQASUR
I $P($G(^XTV(8992,XQAUSER,2,0)),U,2)'>0 Q ;p790
S XQARETD=$$FMADD^XLFDT($$NOW^XLFDT(),-1825) ;p790 retention date for 5 years in the past
S XQAI=0 F S XQAI=$O(^XTV(8992,XQAUSER,2,XQAI)) Q:XQAI'>0 D
. S XQASUR=$G(^XTV(8992,XQAUSER,2,XQAI,0))
. I $$EXPIRED(XQASUR,XQARETD) D DELSUR(XQAI,XQAUSER) ;P790
Q
; p730
DISPSUR(XQAUSER,XQASLIST) ; Prints and returns current list of surrogate periods for a user
; usage: N LIST D DISPSUR^XQAUSER(DUZ,.LIST)
N XQAI
D SUROLIST^XQALSUR1(XQAUSER,.XQASLIST)
I $G(XQASLIST)<1 W !!," No current surrogates",! Q
W !!,"Current Surrogate(s):",?33,"START DATE",?58,"END DATE" ; p754 shortened
F XQAI=0:0 S XQAI=$O(XQASLIST(XQAI)) Q:XQAI'>0 D
. W !,XQAI," ",$P(XQASLIST(XQAI),U,2),?33,$$FMTE^XLFDT($P(XQASLIST(XQAI),U,3)),?58,$$FMTE^XLFDT($P(XQASLIST(XQAI),U,4))
W !
Q
;P790
DELSUR(XQAI,XQAUSER) ;Purge surrogate
N XQAIEN,XQAFDA
S XQAIEN=XQAI_","_XQAUSER_","
S XQAFDA(8992.02,XQAIEN,.01)="@" D FILE^DIE("","XQAFDA")
Q
;p790
EXPIRED(XQASUR,RETDATE) ; called by CLEANUP. SURROGATE return 1 if expired or 0 if not
; RETDATE, retention date, is greater than start (P1) and end (P3) dates
; end date (P3) is not empty (otherwise still active)
; alerts don't need to be returned (P4=0) (alerts already returned)
Q ($P(XQASUR,U)<RETDATE)&($P(XQASUR,U,4)'=1)&($P(XQASUR,U,3)<RETDATE)&($P(XQASUR,U,3)>0)
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXQALSUR2 3397 printed Jun 11, 2024@21:54:07 Page 2
XQALSUR2 ;FO-OAK.SEA/JLI-Continuation of alert surrogate processing ; September 6, 2023@14:28
+1 ;;8.0;KERNEL;**366,513,602,690,730,754,790**;Jul 10, 1995;Build 2
+2 ;Per VHA VA Directive 6402, this routine should not be modified
+3 QUIT
+4 ; added to handle adjustment for manual or Fileman editing of surrogate on top zero node
CHEKSUBS(XQAUSER) ;
+1 NEW XQA0,XQASTR1,XQANOW,XQB0,XQB1
+2 SET XQANOW=$$NOW^XLFDT()
+3 SET XQA0=$GET(^XTV(8992,XQAUSER,0))
IF $PIECE(XQA0,U,2)>0
Begin DoDot:1
+4 NEW XQAFDA,XQAIEN,XQADA
+5 SET XQASTR1=$PIECE(XQA0,U,3)
if XQASTR1'>0
SET XQASTR1=XQANOW
SET XQAFDA(8992,XQAUSER_",",.03)=XQASTR1
Begin DoDot:2
+6 ; p754
SET XQADA=0
FOR
SET XQADA=$ORDER(^XTV(8992,XQAUSER,2,"B",XQASTR1,XQADA))
if XQADA'>0
QUIT
Begin DoDot:3
+7 ;p754 somebody removed surr by gbl kill, cleanup
if '$DATA(^XTV(8992,XQAUSER,2,XQADA,0))
KILL ^XTV(8992,XQAUSER,2,"B",XQASTR1,XQADA)
End DoDot:3
if $PIECE($GET(^XTV(8992,XQAUSER,2,XQADA,0)),U,2)=$PIECE(XQA0,U,2)
QUIT
+8 SET XQAIEN=$SELECT(XQADA>0:XQADA,1:"+1")_","_XQAUSER_","
SET XQAFDA(8992.02,XQAIEN,.01)=XQASTR1
+9 SET XQAFDA(8992.02,XQAIEN,.02)=$PIECE(XQA0,U,2)
if $PIECE(XQA0,U,4)>0
SET XQAFDA(8992.02,XQAIEN,.03)=$PIECE(XQA0,U,4)
+10 if XQADA'>0
DO UPDATE^DIE("","XQAFDA")
+11 if XQADA>0
DO FILE^DIE("","XQAFDA")
+12 QUIT
End DoDot:2
+13 QUIT
End DoDot:1
+14 QUIT
+15 ;
CHKCRIT(ZERONODE) ;EXTRINSIC - check for critical indication for alert
+1 ; ZERONODE - input - Value for zero node for alert data
+2 ; RETURN VALUE - 1 if the alert is indicated as critical
+3 ; 0 otherwise
+4 NEW RESULT,IEN
+5 SET RESULT=0
+6 FOR IEN=0:0
SET IEN=$ORDER(^XTV(8992.3,IEN))
if IEN'>0
QUIT
Begin DoDot:1
+7 NEW IENS,RES,MSG,CRITTEXT,PKGID,ALERTTXT
+8 SET IENS=IEN_","
+9 DO GETS^DIQ(8992.3,IENS,".01:.02",,"RES","MSG")
+10 SET CRITTEXT=$$UP^XLFSTR(RES(8992.3,IENS,.01))
SET PKGID=$$UP^XLFSTR(RES(8992.3,IENS,.02))
+11 IF PKGID'=""
IF $$UP^XLFSTR($PIECE(ZERONODE,U,2))'[PKGID
QUIT
+12 SET ALERTTXT=$$UP^XLFSTR($PIECE(ZERONODE,U,3))
+13 ;;XU*8*690 - Added check for "NON" critical text
IF ALERTTXT[CRITTEXT
IF ALERTTXT'["NOT "_CRITTEXT
IF ALERTTXT'["NON "_CRITTEXT
SET RESULT=1
End DoDot:1
if RESULT
QUIT
+14 QUIT RESULT
+15 ;
CLEANUP(XQAUSER) ;SR. - clean up expired surrogate info
+1 NEW XQAI,XQARETD,XQASUR
+2 ;p790
IF $PIECE($GET(^XTV(8992,XQAUSER,2,0)),U,2)'>0
QUIT
+3 ;p790 retention date for 5 years in the past
SET XQARETD=$$FMADD^XLFDT($$NOW^XLFDT(),-1825)
+4 SET XQAI=0
FOR
SET XQAI=$ORDER(^XTV(8992,XQAUSER,2,XQAI))
if XQAI'>0
QUIT
Begin DoDot:1
+5 SET XQASUR=$GET(^XTV(8992,XQAUSER,2,XQAI,0))
+6 ;P790
IF $$EXPIRED(XQASUR,XQARETD)
DO DELSUR(XQAI,XQAUSER)
End DoDot:1
+7 QUIT
+8 ; p730
DISPSUR(XQAUSER,XQASLIST) ; Prints and returns current list of surrogate periods for a user
+1 ; usage: N LIST D DISPSUR^XQAUSER(DUZ,.LIST)
+2 NEW XQAI
+3 DO SUROLIST^XQALSUR1(XQAUSER,.XQASLIST)
+4 IF $GET(XQASLIST)<1
WRITE !!," No current surrogates",!
QUIT
+5 ; p754 shortened
WRITE !!,"Current Surrogate(s):",?33,"START DATE",?58,"END DATE"
+6 FOR XQAI=0:0
SET XQAI=$ORDER(XQASLIST(XQAI))
if XQAI'>0
QUIT
Begin DoDot:1
+7 WRITE !,XQAI," ",$PIECE(XQASLIST(XQAI),U,2),?33,$$FMTE^XLFDT($PIECE(XQASLIST(XQAI),U,3)),?58,$$FMTE^XLFDT($PIECE(XQASLIST(XQAI),U,4))
End DoDot:1
+8 WRITE !
+9 QUIT
+10 ;P790
DELSUR(XQAI,XQAUSER) ;Purge surrogate
+1 NEW XQAIEN,XQAFDA
+2 SET XQAIEN=XQAI_","_XQAUSER_","
+3 SET XQAFDA(8992.02,XQAIEN,.01)="@"
DO FILE^DIE("","XQAFDA")
+4 QUIT
+5 ;p790
EXPIRED(XQASUR,RETDATE) ; called by CLEANUP. SURROGATE return 1 if expired or 0 if not
+1 ; RETDATE, retention date, is greater than start (P1) and end (P3) dates
+2 ; end date (P3) is not empty (otherwise still active)
+3 ; alerts don't need to be returned (P4=0) (alerts already returned)
+4 QUIT ($PIECE(XQASUR,U)<RETDATE)&($PIECE(XQASUR,U,4)'=1)&($PIECE(XQASUR,U,3)<RETDATE)&($PIECE(XQASUR,U,3)>0)
+5 ;
