HLEVX002 ;O-OIFO/LJA - HL7 Xref Check ;02/04/2004 15:25
;;1.6;HEALTH LEVEL SEVEN;**109**;Oct 13, 1995
;
; Event Types... AC-HUNG, AC-PROC'D, AC-NO 773, AC-NO 870
;
CHECKAC ; Check file 773 AC xref...
N ABRT,CTERR,CTXREF,ERRNO,GBL,IEN773,IEN870,NOW,XTMP,WAY,X
;
D DEBUG^HLEVAPI2("CHECKAC")
D START^HLEVAPI("CTERR^CTXREF")
;
KILL ^TMP($J,"HLEV REP"),^TMP($J,"HLEVREP"),^TMP($J,"HLMAIL773")
;
; Current XMTP
S NOW=$$NOW^XLFDT
S XTMP="HLEV CHK773AC "_NOW
S ^XTMP(XTMP,0)=$$FMADD^XLFDT(NOW,3)_U_NOW_U_"VistA HL7 773 AC Xref Check"_U_"Task# "_$G(ZTSK)
;
; Previous XTMP...
S X=$O(^XTMP(XTMP),-1),XTMP(1)=$S(X["HLEV CHK773AC":X,1:"")
;
S GBL="^HLMA(""AC"")"
; Check Xref...
S WAY="",(ABRT,CTERR,ERRNO)=0
F S WAY=$O(@GBL@(WAY)) Q:WAY']""!(ABRT) D
. S IEN870=0
. F S IEN870=$O(@GBL@(WAY,IEN870)) Q:'IEN870!(ABRT) D
. . S IEN773=0,CTXREF=0
. . F S IEN773=$O(@GBL@(WAY,IEN870,IEN773)) Q:'IEN773!(ABRT) D
. . . S CTXREF=CTXREF+1
. . . I '(CTXREF#1000) D I $$S^%ZTLOAD S ABRT=1 QUIT ;->
. . . . D CHECKIN^HLEVAPI
. . . . S $P(^XTMP(XTMP,0),U,5)=$$NOW^XLFDT
. . . S ^XTMP(XTMP,"CURR",WAY,IEN870,IEN773)=NOW ; Next run record
. . . D CHKAC(WAY,IEN870,IEN773)
;
D CHECKOUT^HLEVAPI
;
S X("HLEV REP")=$NA(^TMP($J,"HLEV REP")) D DEBUG^HLEVAPI2("CHECKAC-3",.X)
;
; Create report global, and move into ^TMP($J,"HLEVREP")...
D GENREP^HLEVUTI0($NA(^TMP($J,"HLEV REP")),$NA(^TMP($J,"HLEVREP")),4,1)
D MAIL773
D MSGTEXT^HLEVAPI1($NA(^TMP($J,"HLEVREP")))
;
; Send email if errors exist...
I ERRNO>0 D
. S HLEVTXT(1)="MESSAGETEXT"
. D MAILIT^HLEVAPI
;
S X("HLEV REP")=$NA(^TMP($J,"HLEV REP")) D DEBUG^HLEVAPI2("CHECKAC-3",.X)
;
KILL ^TMP($J,"HLEV REP"),^TMP($J,"HLEVREP"),^TMP($J,"HLMAIL773")
;
Q
;
CHKAC(WAY,IEN870,IEN773) ; Check AC xref...
;
; Record in ^XTMP... (Next run compared to this for "hangarounds")
S ^XTMP(XTMP,"CURR",WAY,IEN870,IEN773)=NOW
;
S WAY(1)=$S(WAY="I":"IN",1:"OUT")
;
; Does link exist?
I $G(^HLCS(870,+IEN870,0))']"" D QUIT ;->
. D ERR(WAY(1),IEN870,IEN773,"No 870","AC-NO 870")
;
; Make sure zero node exists...
I $G(^HLMA(+IEN773,0))']"" D QUIT ;->
. D ERR(WAY(1),IEN870,IEN773,"No 773","AC-NO 773")
;
; Make sure AC xref should exist...
I $G(^HLMA(+IEN773,"P"))?7N1"."1.N D QUIT ;->
. D ERR(WAY(1),IEN870,IEN773,"Proc'd","AC-PROC'D")
;
; Check only for first entry...
QUIT:CTXREF>1 ;->
;
; Check for "hang around" AC xrefs...
I $G(XTMP(1))]"" D
. ; Quit if didn't exist last run...
. QUIT:'$D(^XTMP(XTMP(1),"CURR",WAY,IEN870,IEN773)) ;->
. QUIT:$P($$UP^XLFSTR($G(^HLCS(870,+IEN870,0))),U,5)["SHUTDOWN" ;->
. D ERR($S(WAY=1:"IN",1:"OUT"),IEN870,IEN773,"Hung#","AC-HUNG")
;
Q
;
ERR(WAY,IEN870,IEN773,REA,ETYPE) ;
; ERRNO -- req
;
; Has this problem already been logged?
QUIT:'$$LOG^HLEVAPI2($G(ETYPE),"WAY^IEN870^IEN773") ;->
;
; $$LOG creates (where AC-HUNG = ETYPE)...
; ^HLEV(776.4,"AH","AC-HUNG","IN",25,15333) = 100
; ^HLEV(776.4,"AH","AC-HUNG","X776",1183,100) = 100
; ^HLEV(776.4,"AH","AC-HUNG","X7764",100,1183) = 100
; 1183 = 776 ien 100 = 776.4 ien
;
S ERRNO=$G(ERRNO)+1
D RECORD^HLEVX000("773 AC-"_REA,WAY,IEN870,IEN773)
S ^TMP($J,"HLMAIL773",IEN870,WAY,+IEN773)=$$NEXTACS(WAY,IEN870,IEN773)
;
Q
;
NEXTACS(WAY,IEN870,I773) ; Store the next two entries...
N CT,NEXTIENS
S WAY=$E(WAY),NEXTIENS="",CT=0
F S I773=$O(^HLMA("AC",WAY,IEN870,I773)) Q:'I773!(CT=2) D
. S CT=CT+1
. S NEXTIENS=NEXTIENS_$S(NEXTIENS]"":U,1:"")_I773
Q NEXTIENS
;
MAIL773 ; Add collected 773 entry data to email message...
N CT,I773,IEN773,IEN870,LINKNM,NEXTACS,WAY
;
D ADD("")
;
S IEN870=0
F S IEN870=$O(^TMP($J,"HLMAIL773",IEN870)) Q:IEN870'>0 D
. S DATA=$G(^HLCS(870,+IEN870,0))
. S LINKNM=$P(DATA,U)_" [#"_IEN870_"] "
. D ADD("")
. D ADD($$CJ^XLFSTR(LINKNM_" ",74,"="))
. F NODE=0,100,200,300,400 D ADDNODE(NODE,NODE,IEN870)
. S WAY=""
. F S WAY=$O(^TMP($J,"HLMAIL773",IEN870,WAY)) Q:WAY']"" D
. . S IEN773=0,CT=0
. . F S IEN773=$O(^TMP($J,"HLMAIL773",IEN870,WAY,IEN773)) Q:IEN773'>0 D
. . . S CT=CT+1
. . . I CT=1 D ADD($$CJ^XLFSTR(" "_$S($E(WAY)="I":"INCOMING",1:"OUTGOING")_" ",74,"="))
. . . D DATA773(+IEN773," Problem AC Entry ") ; Problem entry...
. . . ; Add next two 773s...
. . . S NEXTACS=$G(^TMP($J,"HLMAIL773",IEN870,WAY,IEN773)) QUIT:NEXTACS']"" ;->
. . . F PCE=1:1:$L(NEXTACS,U) D
. . . . S I773=+$P(NEXTACS,U,PCE) QUIT:I773'>0 ;->
. . . . D DATA773(I773," Entry After AC Problem ")
;
Q
;
ADDNODE(NODE,NAME,IEN870) ; Add node data prefixed by node name...
N DATA,PFX
S PFX=$S(NODE=+NODE:"",1:"""")
S DATA="^HLCS(870,"_IEN870_","_PFX_NAME_PFX_")="_$G(^HLCS(870,+IEN870,NODE))
D ADD(DATA)
Q
;
DATA773(IEN773,PROBL) ; Add critical data to Email message...
N DATA773,NO
;
D ADD($$CJ^XLFSTR($G(PROBL),74,"="))
;
KILL ^TMP($J,"HLDATA773")
;
; Collect 773 informaiton...
D ENDIQ1^HLEVUTIL(773,+IEN773,"HLDATA773")
;
S ^TMP($J,"HLDATA773",1)=" "_$$CJ^XLFSTR(" 773# "_IEN773_" ",60,"-")_" "
S NO=0
F S NO=$O(^TMP($J,"HLDATA773",NO)) Q:NO'>0 D
. D ADD(^TMP($J,"HLDATA773",+NO))
;
KILL ^TMP($J,"HLDATA773")
;
Q
;
ADD(TXT,TRAIL) ; Add TXT to ^TMP($J,"HLEVREP",#)...
N COL,LEN,NO,TXTOLD
;
S LEN=$L($P(TXT,"=")),LEN=$S('LEN:3,LEN<55:LEN+1,1:3)
;
F D QUIT:TXT']""
. S NO=$O(^TMP($J,"HLEVREP",":"),-1)+1
. S ^TMP($J,"HLEVREP",+NO)=$E(TXT,1,74)
. S TXT=$E(TXT,75,999) QUIT:TXT']"" ;->
. S TXT=$$REPEAT^XLFSTR(" ",LEN)_TXT
;
Q
;
EOR ;HLEVX002 - VistA HL7 Event Monitor Code ;5/30/03 15:25
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLEVX002 5747 printed Oct 16, 2024@17:58:55 Page 2
HLEVX002 ;O-OIFO/LJA - HL7 Xref Check ;02/04/2004 15:25
+1 ;;1.6;HEALTH LEVEL SEVEN;**109**;Oct 13, 1995
+2 ;
+3 ; Event Types... AC-HUNG, AC-PROC'D, AC-NO 773, AC-NO 870
+4 ;
CHECKAC ; Check file 773 AC xref...
+1 NEW ABRT,CTERR,CTXREF,ERRNO,GBL,IEN773,IEN870,NOW,XTMP,WAY,X
+2 ;
+3 DO DEBUG^HLEVAPI2("CHECKAC")
+4 DO START^HLEVAPI("CTERR^CTXREF")
+5 ;
+6 KILL ^TMP($JOB,"HLEV REP"),^TMP($JOB,"HLEVREP"),^TMP($JOB,"HLMAIL773")
+7 ;
+8 ; Current XMTP
+9 SET NOW=$$NOW^XLFDT
+10 SET XTMP="HLEV CHK773AC "_NOW
+11 SET ^XTMP(XTMP,0)=$$FMADD^XLFDT(NOW,3)_U_NOW_U_"VistA HL7 773 AC Xref Check"_U_"Task# "_$GET(ZTSK)
+12 ;
+13 ; Previous XTMP...
+14 SET X=$ORDER(^XTMP(XTMP),-1)
SET XTMP(1)=$SELECT(X["HLEV CHK773AC":X,1:"")
+15 ;
+16 SET GBL="^HLMA(""AC"")"
+17 ; Check Xref...
+18 SET WAY=""
SET (ABRT,CTERR,ERRNO)=0
+19 FOR
SET WAY=$ORDER(@GBL@(WAY))
if WAY']""!(ABRT)
QUIT
Begin DoDot:1
+20 SET IEN870=0
+21 FOR
SET IEN870=$ORDER(@GBL@(WAY,IEN870))
if 'IEN870!(ABRT)
QUIT
Begin DoDot:2
+22 SET IEN773=0
SET CTXREF=0
+23 FOR
SET IEN773=$ORDER(@GBL@(WAY,IEN870,IEN773))
if 'IEN773!(ABRT)
QUIT
Begin DoDot:3
+24 SET CTXREF=CTXREF+1
+25 ;->
IF '(CTXREF#1000)
Begin DoDot:4
+26 DO CHECKIN^HLEVAPI
+27 SET $PIECE(^XTMP(XTMP,0),U,5)=$$NOW^XLFDT
End DoDot:4
IF $$S^%ZTLOAD
SET ABRT=1
QUIT
+28 ; Next run record
SET ^XTMP(XTMP,"CURR",WAY,IEN870,IEN773)=NOW
+29 DO CHKAC(WAY,IEN870,IEN773)
End DoDot:3
End DoDot:2
End DoDot:1
+30 ;
+31 DO CHECKOUT^HLEVAPI
+32 ;
+33 SET X("HLEV REP")=$NAME(^TMP($JOB,"HLEV REP"))
DO DEBUG^HLEVAPI2("CHECKAC-3",.X)
+34 ;
+35 ; Create report global, and move into ^TMP($J,"HLEVREP")...
+36 DO GENREP^HLEVUTI0($NAME(^TMP($JOB,"HLEV REP")),$NAME(^TMP($JOB,"HLEVREP")),4,1)
+37 DO MAIL773
+38 DO MSGTEXT^HLEVAPI1($NAME(^TMP($JOB,"HLEVREP")))
+39 ;
+40 ; Send email if errors exist...
+41 IF ERRNO>0
Begin DoDot:1
+42 SET HLEVTXT(1)="MESSAGETEXT"
+43 DO MAILIT^HLEVAPI
End DoDot:1
+44 ;
+45 SET X("HLEV REP")=$NAME(^TMP($JOB,"HLEV REP"))
DO DEBUG^HLEVAPI2("CHECKAC-3",.X)
+46 ;
+47 KILL ^TMP($JOB,"HLEV REP"),^TMP($JOB,"HLEVREP"),^TMP($JOB,"HLMAIL773")
+48 ;
+49 QUIT
+50 ;
CHKAC(WAY,IEN870,IEN773) ; Check AC xref...
+1 ;
+2 ; Record in ^XTMP... (Next run compared to this for "hangarounds")
+3 SET ^XTMP(XTMP,"CURR",WAY,IEN870,IEN773)=NOW
+4 ;
+5 SET WAY(1)=$SELECT(WAY="I":"IN",1:"OUT")
+6 ;
+7 ; Does link exist?
+8 ;->
IF $GET(^HLCS(870,+IEN870,0))']""
Begin DoDot:1
+9 DO ERR(WAY(1),IEN870,IEN773,"No 870","AC-NO 870")
End DoDot:1
QUIT
+10 ;
+11 ; Make sure zero node exists...
+12 ;->
IF $GET(^HLMA(+IEN773,0))']""
Begin DoDot:1
+13 DO ERR(WAY(1),IEN870,IEN773,"No 773","AC-NO 773")
End DoDot:1
QUIT
+14 ;
+15 ; Make sure AC xref should exist...
+16 ;->
IF $GET(^HLMA(+IEN773,"P"))?7N1"."1.N
Begin DoDot:1
+17 DO ERR(WAY(1),IEN870,IEN773,"Proc'd","AC-PROC'D")
End DoDot:1
QUIT
+18 ;
+19 ; Check only for first entry...
+20 ;->
if CTXREF>1
QUIT
+21 ;
+22 ; Check for "hang around" AC xrefs...
+23 IF $GET(XTMP(1))]""
Begin DoDot:1
+24 ; Quit if didn't exist last run...
+25 ;->
if '$DATA(^XTMP(XTMP(1),"CURR",WAY,IEN870,IEN773))
QUIT
+26 ;->
if $PIECE($$UP^XLFSTR($GET(^HLCS(870,+IEN870,0))),U,5)["SHUTDOWN"
QUIT
+27 DO ERR($SELECT(WAY=1:"IN",1:"OUT"),IEN870,IEN773,"Hung#","AC-HUNG")
End DoDot:1
+28 ;
+29 QUIT
+30 ;
ERR(WAY,IEN870,IEN773,REA,ETYPE) ;
+1 ; ERRNO -- req
+2 ;
+3 ; Has this problem already been logged?
+4 ;->
if '$$LOG^HLEVAPI2($GET(ETYPE),"WAY^IEN870^IEN773")
QUIT
+5 ;
+6 ; $$LOG creates (where AC-HUNG = ETYPE)...
+7 ; ^HLEV(776.4,"AH","AC-HUNG","IN",25,15333) = 100
+8 ; ^HLEV(776.4,"AH","AC-HUNG","X776",1183,100) = 100
+9 ; ^HLEV(776.4,"AH","AC-HUNG","X7764",100,1183) = 100
+10 ; 1183 = 776 ien 100 = 776.4 ien
+11 ;
+12 SET ERRNO=$GET(ERRNO)+1
+13 DO RECORD^HLEVX000("773 AC-"_REA,WAY,IEN870,IEN773)
+14 SET ^TMP($JOB,"HLMAIL773",IEN870,WAY,+IEN773)=$$NEXTACS(WAY,IEN870,IEN773)
+15 ;
+16 QUIT
+17 ;
NEXTACS(WAY,IEN870,I773) ; Store the next two entries...
+1 NEW CT,NEXTIENS
+2 SET WAY=$EXTRACT(WAY)
SET NEXTIENS=""
SET CT=0
+3 FOR
SET I773=$ORDER(^HLMA("AC",WAY,IEN870,I773))
if 'I773!(CT=2)
QUIT
Begin DoDot:1
+4 SET CT=CT+1
+5 SET NEXTIENS=NEXTIENS_$SELECT(NEXTIENS]"":U,1:"")_I773
End DoDot:1
+6 QUIT NEXTIENS
+7 ;
MAIL773 ; Add collected 773 entry data to email message...
+1 NEW CT,I773,IEN773,IEN870,LINKNM,NEXTACS,WAY
+2 ;
+3 DO ADD("")
+4 ;
+5 SET IEN870=0
+6 FOR
SET IEN870=$ORDER(^TMP($JOB,"HLMAIL773",IEN870))
if IEN870'>0
QUIT
Begin DoDot:1
+7 SET DATA=$GET(^HLCS(870,+IEN870,0))
+8 SET LINKNM=$PIECE(DATA,U)_" [#"_IEN870_"] "
+9 DO ADD("")
+10 DO ADD($$CJ^XLFSTR(LINKNM_" ",74,"="))
+11 FOR NODE=0,100,200,300,400
DO ADDNODE(NODE,NODE,IEN870)
+12 SET WAY=""
+13 FOR
SET WAY=$ORDER(^TMP($JOB,"HLMAIL773",IEN870,WAY))
if WAY']""
QUIT
Begin DoDot:2
+14 SET IEN773=0
SET CT=0
+15 FOR
SET IEN773=$ORDER(^TMP($JOB,"HLMAIL773",IEN870,WAY,IEN773))
if IEN773'>0
QUIT
Begin DoDot:3
+16 SET CT=CT+1
+17 IF CT=1
DO ADD($$CJ^XLFSTR(" "_$SELECT($EXTRACT(WAY)="I":"INCOMING",1:"OUTGOING")_" ",74,"="))
+18 ; Problem entry...
DO DATA773(+IEN773," Problem AC Entry ")
+19 ; Add next two 773s...
+20 ;->
SET NEXTACS=$GET(^TMP($JOB,"HLMAIL773",IEN870,WAY,IEN773))
if NEXTACS']""
QUIT
+21 FOR PCE=1:1:$LENGTH(NEXTACS,U)
Begin DoDot:4
+22 ;->
SET I773=+$PIECE(NEXTACS,U,PCE)
if I773'>0
QUIT
+23 DO DATA773(I773," Entry After AC Problem ")
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+24 ;
+25 QUIT
+26 ;
ADDNODE(NODE,NAME,IEN870) ; Add node data prefixed by node name...
+1 NEW DATA,PFX
+2 SET PFX=$SELECT(NODE=+NODE:"",1:"""")
+3 SET DATA="^HLCS(870,"_IEN870_","_PFX_NAME_PFX_")="_$GET(^HLCS(870,+IEN870,NODE))
+4 DO ADD(DATA)
+5 QUIT
+6 ;
DATA773(IEN773,PROBL) ; Add critical data to Email message...
+1 NEW DATA773,NO
+2 ;
+3 DO ADD($$CJ^XLFSTR($GET(PROBL),74,"="))
+4 ;
+5 KILL ^TMP($JOB,"HLDATA773")
+6 ;
+7 ; Collect 773 informaiton...
+8 DO ENDIQ1^HLEVUTIL(773,+IEN773,"HLDATA773")
+9 ;
+10 SET ^TMP($JOB,"HLDATA773",1)=" "_$$CJ^XLFSTR(" 773# "_IEN773_" ",60,"-")_" "
+11 SET NO=0
+12 FOR
SET NO=$ORDER(^TMP($JOB,"HLDATA773",NO))
if NO'>0
QUIT
Begin DoDot:1
+13 DO ADD(^TMP($JOB,"HLDATA773",+NO))
End DoDot:1
+14 ;
+15 KILL ^TMP($JOB,"HLDATA773")
+16 ;
+17 QUIT
+18 ;
ADD(TXT,TRAIL) ; Add TXT to ^TMP($J,"HLEVREP",#)...
+1 NEW COL,LEN,NO,TXTOLD
+2 ;
+3 SET LEN=$LENGTH($PIECE(TXT,"="))
SET LEN=$SELECT('LEN:3,LEN<55:LEN+1,1:3)
+4 ;
+5 FOR
Begin DoDot:1
+6 SET NO=$ORDER(^TMP($JOB,"HLEVREP",":"),-1)+1
+7 SET ^TMP($JOB,"HLEVREP",+NO)=$EXTRACT(TXT,1,74)
+8 ;->
SET TXT=$EXTRACT(TXT,75,999)
if TXT']""
QUIT
+9 SET TXT=$$REPEAT^XLFSTR(" ",LEN)_TXT
End DoDot:1
if TXT']""
QUIT
+10 ;
+11 QUIT
+12 ;
EOR ;HLEVX002 - VistA HL7 Event Monitor Code ;5/30/03 15:25
