- 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 Feb 18, 2025@23:31:55 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 ;