HLEVX000 ;O-OIFO/LJA - VistA HL7 Event Monitor Code ;02/04/2004 15:25
;;1.6;HEALTH LEVEL SEVEN;**109**;Oct 13, 1995
;
; Event Types - 870-DINUM, 870-SKIP, 870-STUB
;
CHK870 ; Search for various file 870 problems...
;
; {01/16/04 - See call to REPDINUM below.}
;
N CT870,CTERR,CTNO,CTSTUB,DATA,DATABEF,IEN870,LINKNM,MIEN870
N NOW,STATUS,TXT,VAR,WAY,XTMPBEF,XTMPNOW
;
; Call event monitor...
KILL VAR
; Variables can be defined prior to passing into START by reference...
F VAR="CT870","CTDINUM","CTERR" S VAR(VAR)="" ; #1-Indiv array elements
S VAR="CTNO^CTSKIP^CTSTUB" ; #2-Parsed from string
D START^HLEVAPI(.VAR)
; Even D START^HLEVAPI(VAR) would work...
;
KILL ^TMP($J,"HLREP"),^TMP($J,"HLEV REP"),^TMP($J,"HLMAIL")
;
; Set current XTMP subscript and create zero node...
S NOW=$$NOW^XLFDT,XTMPNOW="HLEV STUB "_NOW
S ^XTMP(XTMPNOW,0)=$$FMADD^XLFDT(NOW,2)_U_NOW_U_"HLEV Stub Record Search"
;
; Has there been a prior run? If so, set XTMPBEF. If not, set to null
S XTMPBEF=$O(^XTMP(XTMPNOW),-1),XTMPBEF=$S(XTMPBEF["HLEV STUB ":XTMPBEF,1:"")
;
; Find current stub entries...
S (CT870,CTDINUM,CTERR,CTNO,CTSKIP,CTSTUB)=0,IEN870=0,CTNO=0
F S IEN870=$O(^HLCS(870,IEN870)) Q:IEN870'>0 D
. D CHECKIN^HLEVAPI
. S CT870=CT870+1
. S LINKNM=$P($G(^HLCS(870,+IEN870,0)),U)
. S LINKNM=$S(LINKNM]"":LINKNM_"["_IEN870_"]",1:"IEN ["_IEN870_"]")
. ; 1=IN QUEUE 2=OUT QUEUE
. F WAY=1,2 D
. . S WAY(1)=$S(WAY=1:"I",1:"O")
. . D CHECKIN^HLEVAPI
. . S MIEN870=$O(^HLCS(870,+IEN870,WAY,0)) ; First entry...
. . S MIEN870(1)=$O(^HLCS(870,+IEN870,WAY,":"),-1) ; Last entry...
. . Q:MIEN870'>0!(MIEN870(1)'>0) ;->
. . F MIEN870=MIEN870:1:MIEN870(1) D
. . . S CTNO=CTNO+1
. . . I '(CTNO#500) D CHECKIN^HLEVAPI
. . . D CHECKS(IEN870,WAY,MIEN870)
;
D CHECKIN^HLEVAPI ; To store final values of variables
D CHECKOUT^HLEVAPI ; To finalize fields...
;
S ^XTMP(XTMPNOW,0,0)=CT870_U_CTNO_"~"_CTERR_"~"_CTDINUM_U_CTSKIP_U_CTSTUB
;
; Create report and put in text...
QUIT:'$D(^TMP($J,"HLEV REP")) ;->
;
; Create report text...
D GENREP^HLEVUTI0($NA(^TMP($J,"HLEV REP")),$NA(^TMP($J,"HLEVREP")),4,1)
;
; Load report text in 776 message text...
D MSGTEXT^HLEVAPI1($NA(^TMP($J,"HLEVREP")))
;
; Mail report...
S HLEVTXT(1)="MESSAGETEXT"
D MAILIT^HLEVAPI
;
; Report DINUM problems, using report text...
D REPDINUM^HLEVX003 ; {01/16/04}
;
; Clean out ^TMP data...
KILL ^TMP($J,"HLREP"),^TMP($J,"HLEV REP"),^TMP($J,"HLMAIL")
;
Q
;
SITE S SITE=$$SITE^VASITE,SITE=$P(SITE,U,2)_" ["_$P(SITE,U,3)_"]"
D ADD("Run site: "_SITE)
D ADD("")
;
EXPL D ADD("Some stub entries exist in the HL Logical Link file (#870) that")
D ADD("appear to be ""stuck"". Someone at the site needs to check out")
D ADD("and possibly change their status to DONE.")
;
HDR D ADD("")
D ADD("Link In/Out IENs")
D ADD($$REPEAT^XLFSTR("-",74))
;
; Send report...
REP S LINKNM=""
F S LINKNM=$O(^TMP($J,"HLEV REP",LINKNM)) Q:LINKNM']"" D
. S TXT=$E(LINKNM_" ",1,15)
. S WAY="",CTNO=0
. F S WAY=$O(^TMP($J,"HLEV REP",LINKNM,WAY)) Q:WAY']"" D
. . S TXT=$E(TXT_" "_$S(WAY="I":"IN",1:"OUT")_$$REPEAT^XLFSTR(" ",80),1,25)
. . S MIEN870=0
. . F S MIEN870=$O(^TMP($J,"HLEV REP",LINKNM,WAY,MIEN870)) Q:MIEN870'>0 D
. . . S CTNO=CTNO+1
. . . I ($L(TXT)+$L(MIEN870)+2)>74 D QUIT ;->
. . . . D ADD(TXT)
. . . . S TXT=$$REPEAT^XLFSTR(" ",25)
. . . S TXT=TXT_$S($L(TXT)>25:",",1:"")_MIEN870
. . I $TR(TXT," ","")]"" D ADD(TXT)
. . S TXT=$$REPEAT^XLFSTR(" ",15)
. I TXT]"" D ADD(TXT) S TXT=""
I TXT]"" D ADD(TXT) S TXT=""
;
D MSGTEXT^HLEVAPI1($NA(^TMP($J,"HLMAIL")))
;
KILL ^TMP($J,"HLEV REP"),^TMP($J,"HLMAIL")
;
S HLEVTXT(1)="MESSAGE TEXT"
D MAILIT^HLEVAPI
;
Q
;
ADD(TXT) ; Add to global for moving into report
N NO
S NO=$O(^TMP($J,"HLMAIL",":"),-1)+1
S ^TMP($J,"HLMAIL",+NO)=TXT
Q
;
MSG(TXT) ; Generic text displayer...
W !!,TXT
W ! ; Always put at least one blank row in place
F Q:($Y+3)>IOSL W !
S X=$$BTE^HLCSMON("Press RETURN to exit... ")
Q
;
CHECKS(IEN870,WAY,MIEN870) ; Perform various checks on queue entry...
; CTDINUM,CTSKIP,CTSTUB -- req
QUIT:'$$DATA870(IEN870,WAY,MIEN870) ;->
D CHKSTUB(IEN870,WAY,MIEN870)
D CHKDINUM(IEN870,WAY,MIEN870)
Q
;
DATA870(IEN870,WAY,MIEN870) ; Does record exist?
; CTSKIP,LINKNM -- req
;
; Check for existence of data here...
QUIT:$G(^HLCS(870,+IEN870,WAY,+MIEN870,0))]"" 1 ;->
;
S WAY(1)=$S(WAY=1:"INCOMING",1:"OUTGOING")
;
; Has this problem already been logged?
QUIT:'$$LOG^HLEVAPI2("870-SKIP","IEN870^WAY^MIEN870") "" ;->
;
D RECORD("SKIP",LINKNM,WAY(1),MIEN870)
S CTSKIP=CTSKIP+1,CTERR=CTERR+1
;
Q ""
;
CHKSTUB(IEN870,WAY,MIEN870) ; Check if a stub record that "hangs around"
; CTSTUB,LINKNM -- req
N DATABEF,STATUS
S STATUS=$P($G(^HLCS(870,+IEN870,+WAY,+MIEN870,0)),U,2)
QUIT:STATUS'="S" ;-> Stub record
S WAY(1)=$S(WAY=1:"INCOMING",1:"OUTGOING")
S DATABEF=$S(XTMPBEF']"":"",1:$S($D(^XTMP(XTMPBEF,+IEN870,WAY(1),+MIEN870)):1,1:""))
S ^XTMP(XTMPNOW,+IEN870,WAY(1),+MIEN870)=DATABEF
QUIT:'DATABEF ;-> Stub entry didn't exist before...
;
; Has this problem already been logged?
QUIT:'$$LOG^HLEVAPI2("870-STUB","IEN870^WAY^MIEN870") ;->
;
D RECORD("STUB",LINKNM,WAY(1),MIEN870)
S CTSTUB=CTSTUB+1,CTERR=CTERR+1
;
Q
;
CHKDINUM(IEN870,WAY,MIEN870) ; Check for records not DINUMd for log link
; CTDINUM,LINKNM -- req
;
; {01/16/04 - Call to $$LOG^HLEVAPI2 removed. See REPDINUM call.}
;
N IEN
;
; DINUM check here...
S IEN=+$G(^HLCS(870,+IEN870,WAY,+MIEN870,0)) QUIT:IEN=MIEN870 ;->
;
S WAY(1)=$S(WAY=1:"INCOMING",1:"OUTGOING")
;
; New occurence, so record error...
D RECORD("DINUM",LINKNM,WAY(1),MIEN870)
S CTDINUM=CTDINUM+1,CTERR=CTERR+1
;
Q
;
RECORD(PROBL,LINKNM,WAY,MIEN870) ; Record for later inclusion in report
;
; Required: At least two levels passed...
S PROBL=$G(PROBL) QUIT:PROBL']"" ;->
S LINKNM=$G(LINKNM) QUIT:LINKNM']"" ;->
S LEVEL=2
S WAY=$G(WAY) I WAY]"" S LEVEL=3
S MIEN870=$G(MIEN870) I MIEN870]"" S LEVEL=4
;
; Data level set...
I LEVEL=4 S ^TMP($J,"HLEV REP",PROBL,LINKNM,WAY,MIEN870)=""
I LEVEL=3 S ^TMP($J,"HLEV REP",PROBL,LINKNM,WAY)=""
I LEVEL=2 S ^TMP($J,"HLEV REP",PROBL,LINKNM)=""
;
; Total level sets...
I LEVEL=4 S ^TMP($J,"HLEV REP",PROBL,LINKNM,WAY)=$G(^TMP($J,"HLEV REP",PROBL,LINKNM,WAY))+1
I LEVEL=3 S ^TMP($J,"HLEV REP",PROBL,LINKNM)=$G(^TMP($J,"HLEV REP",PROBL,LINKNM))+1
S ^TMP($J,"HLEV REP",PROBL)=$G(^TMP($J,"HLEV REP",PROBL))+1
S ^TMP($J,"HLEV REP")=$G(^TMP($J,"HLEV REP"))+1
;
Q
;
; ====================================================================
;
CORRECT ; Correct a stub entry in HLCS(870)...
N IEN870,MIEN870,WAY
D HD,EX
S WAY=$$WAY I WAY']"" D QUIT ;->
. D MSG("Exiting... ")
W !
S IEN870=$$LINK I IEN870']"" D QUIT ;->
. D MSG("No link selected. Start again... ")
CONT W !
S MIEN870=$$MIEN870(IEN870,WAY) I MIEN870'>0 D QUIT ;->
. D MSG("No stub entry exists for link.")
W !!,"Stub record# ",MIEN870," found. It's status is about to be changed to DONE..."
W !
QUIT:'$$YN^HLCSRPT4("OK to correct","Yes") ;->
D FIX(IEN870,WAY,MIEN870,"D")
W " fixed... "
W !
QUIT:$$BTE^HLCSMON("Press RETURN to continue searching... ") ;->
G CONT ;->
;
FIX(IEN870,WAY,MIEN870,STAT) ; Fix stub record...
N DA,DIE,DR,SUBDD
S DIE="^HLCS(870,"_IEN870_","_WAY_","
S DA(1)=IEN870,DA=+MIEN870
S DR=$S($G(STAT)]"":"1///"_STAT,1:1)
D ^DIE
Q
;
WAY() ; In or Out?
N DIR,DIRUT,DTOUT,DUOUT,X,Y
S DIR(0)="SO^1:Search the IN QUEUE;2:Search the OUT QUEUE"
S DIR("A")="Select the QUEUE to search"
D ^DIR
QUIT:$D(DIRUT)!($D(DTOUT))!($D(DUOUT)) "" ;->
Q $S(+Y:+Y,1:"")
;
LINK() ; Which 870 entry?
N DIC,X,Y
S DIC=870,DIC(0)="AEMQ",DIC("A")="Select LOGICAL LINK: "
D ^DIC
Q $S(+Y:+Y,1:"")
;
MIEN870(IEN870,WAY) ; Search for stub record...
N CT,IEN,IOINHI,IOINORM,MIEN870,STATUS,X
;
S X="IOINHI;IOINORM" D ENDR^%ZISS
;
W !,IOINHI,"Searching for stub records...",IOINORM
S CT=0,IEN=0,MIEN870=0
F S IEN=$O(^HLCS(870,+IEN870,WAY,IEN)) Q:IEN'>0!(MIEN870) D
. S CT=CT+1 W:'(CT#500) "."
. S DATA=$G(^HLCS(870,+IEN870,WAY,IEN,0)) QUIT:$P(DATA,U,2)'="S" ;->
. H 15 ; If not hung, and is a proper stub entry, it will disappear
. S DATA=$G(^HLCS(870,+IEN870,WAY,IEN,0)) QUIT:$P(DATA,U,2)'="S" ;->
. S MIEN870=IEN
;
Q MIEN870
;
HD W @IOF,$$CJ^XLFSTR("Stub Record Correction",IOM)
W !,$$REPEAT^XLFSTR("=",IOM)
QUIT
;
EX N I,T F I=1:1 S T=$T(EX+I) QUIT:T'[";;" W !,$P(T,";;",2,99)
;;Occasionally, entry's in the IN QUEUE and the OUT QUEUE of the HL Logical
;;Link file (#870) get stuck in the STUB status. (Stub records have the STATUS
;;field set to STUB.) When this occurs, no further processing of the queue
;;occurs.
;;
;;This utility loops through the IN QUEUE or the OUT QUEUE of a logical link
;;looking for stub records. (Stub records have the STATUS field set to STUB.)
;;When it finds a stub record it requests permission to set the STATUS field to
;;DONE.
QUIT
;
EOR ;HLEVX000 - VistA HL7 Event Monitor Code ;5/30/03 15:25
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLEVX000 9392 printed Nov 22, 2024@17:08:12 Page 2
HLEVX000 ;O-OIFO/LJA - VistA HL7 Event Monitor Code ;02/04/2004 15:25
+1 ;;1.6;HEALTH LEVEL SEVEN;**109**;Oct 13, 1995
+2 ;
+3 ; Event Types - 870-DINUM, 870-SKIP, 870-STUB
+4 ;
CHK870 ; Search for various file 870 problems...
+1 ;
+2 ; {01/16/04 - See call to REPDINUM below.}
+3 ;
+4 NEW CT870,CTERR,CTNO,CTSTUB,DATA,DATABEF,IEN870,LINKNM,MIEN870
+5 NEW NOW,STATUS,TXT,VAR,WAY,XTMPBEF,XTMPNOW
+6 ;
+7 ; Call event monitor...
+8 KILL VAR
+9 ; Variables can be defined prior to passing into START by reference...
+10 ; #1-Indiv array elements
FOR VAR="CT870","CTDINUM","CTERR"
SET VAR(VAR)=""
+11 ; #2-Parsed from string
SET VAR="CTNO^CTSKIP^CTSTUB"
+12 DO START^HLEVAPI(.VAR)
+13 ; Even D START^HLEVAPI(VAR) would work...
+14 ;
+15 KILL ^TMP($JOB,"HLREP"),^TMP($JOB,"HLEV REP"),^TMP($JOB,"HLMAIL")
+16 ;
+17 ; Set current XTMP subscript and create zero node...
+18 SET NOW=$$NOW^XLFDT
SET XTMPNOW="HLEV STUB "_NOW
+19 SET ^XTMP(XTMPNOW,0)=$$FMADD^XLFDT(NOW,2)_U_NOW_U_"HLEV Stub Record Search"
+20 ;
+21 ; Has there been a prior run? If so, set XTMPBEF. If not, set to null
+22 SET XTMPBEF=$ORDER(^XTMP(XTMPNOW),-1)
SET XTMPBEF=$SELECT(XTMPBEF["HLEV STUB ":XTMPBEF,1:"")
+23 ;
+24 ; Find current stub entries...
+25 SET (CT870,CTDINUM,CTERR,CTNO,CTSKIP,CTSTUB)=0
SET IEN870=0
SET CTNO=0
+26 FOR
SET IEN870=$ORDER(^HLCS(870,IEN870))
if IEN870'>0
QUIT
Begin DoDot:1
+27 DO CHECKIN^HLEVAPI
+28 SET CT870=CT870+1
+29 SET LINKNM=$PIECE($GET(^HLCS(870,+IEN870,0)),U)
+30 SET LINKNM=$SELECT(LINKNM]"":LINKNM_"["_IEN870_"]",1:"IEN ["_IEN870_"]")
+31 ; 1=IN QUEUE 2=OUT QUEUE
+32 FOR WAY=1,2
Begin DoDot:2
+33 SET WAY(1)=$SELECT(WAY=1:"I",1:"O")
+34 DO CHECKIN^HLEVAPI
+35 ; First entry...
SET MIEN870=$ORDER(^HLCS(870,+IEN870,WAY,0))
+36 ; Last entry...
SET MIEN870(1)=$ORDER(^HLCS(870,+IEN870,WAY,":"),-1)
+37 ;->
if MIEN870'>0!(MIEN870(1)'>0)
QUIT
+38 FOR MIEN870=MIEN870:1:MIEN870(1)
Begin DoDot:3
+39 SET CTNO=CTNO+1
+40 IF '(CTNO#500)
DO CHECKIN^HLEVAPI
+41 DO CHECKS(IEN870,WAY,MIEN870)
End DoDot:3
End DoDot:2
End DoDot:1
+42 ;
+43 ; To store final values of variables
DO CHECKIN^HLEVAPI
+44 ; To finalize fields...
DO CHECKOUT^HLEVAPI
+45 ;
+46 SET ^XTMP(XTMPNOW,0,0)=CT870_U_CTNO_"~"_CTERR_"~"_CTDINUM_U_CTSKIP_U_CTSTUB
+47 ;
+48 ; Create report and put in text...
+49 ;->
if '$DATA(^TMP($JOB,"HLEV REP"))
QUIT
+50 ;
+51 ; Create report text...
+52 DO GENREP^HLEVUTI0($NAME(^TMP($JOB,"HLEV REP")),$NAME(^TMP($JOB,"HLEVREP")),4,1)
+53 ;
+54 ; Load report text in 776 message text...
+55 DO MSGTEXT^HLEVAPI1($NAME(^TMP($JOB,"HLEVREP")))
+56 ;
+57 ; Mail report...
+58 SET HLEVTXT(1)="MESSAGETEXT"
+59 DO MAILIT^HLEVAPI
+60 ;
+61 ; Report DINUM problems, using report text...
+62 ; {01/16/04}
DO REPDINUM^HLEVX003
+63 ;
+64 ; Clean out ^TMP data...
+65 KILL ^TMP($JOB,"HLREP"),^TMP($JOB,"HLEV REP"),^TMP($JOB,"HLMAIL")
+66 ;
+67 QUIT
+68 ;
SITE SET SITE=$$SITE^VASITE
SET SITE=$PIECE(SITE,U,2)_" ["_$PIECE(SITE,U,3)_"]"
+1 DO ADD("Run site: "_SITE)
+2 DO ADD("")
+3 ;
EXPL DO ADD("Some stub entries exist in the HL Logical Link file (#870) that")
+1 DO ADD("appear to be ""stuck"". Someone at the site needs to check out")
+2 DO ADD("and possibly change their status to DONE.")
+3 ;
HDR DO ADD("")
+1 DO ADD("Link In/Out IENs")
+2 DO ADD($$REPEAT^XLFSTR("-",74))
+3 ;
+4 ; Send report...
REP SET LINKNM=""
+1 FOR
SET LINKNM=$ORDER(^TMP($JOB,"HLEV REP",LINKNM))
if LINKNM']""
QUIT
Begin DoDot:1
+2 SET TXT=$EXTRACT(LINKNM_" ",1,15)
+3 SET WAY=""
SET CTNO=0
+4 FOR
SET WAY=$ORDER(^TMP($JOB,"HLEV REP",LINKNM,WAY))
if WAY']""
QUIT
Begin DoDot:2
+5 SET TXT=$EXTRACT(TXT_" "_$SELECT(WAY="I":"IN",1:"OUT")_$$REPEAT^XLFSTR(" ",80),1,25)
+6 SET MIEN870=0
+7 FOR
SET MIEN870=$ORDER(^TMP($JOB,"HLEV REP",LINKNM,WAY,MIEN870))
if MIEN870'>0
QUIT
Begin DoDot:3
+8 SET CTNO=CTNO+1
+9 ;->
IF ($LENGTH(TXT)+$LENGTH(MIEN870)+2)>74
Begin DoDot:4
+10 DO ADD(TXT)
+11 SET TXT=$$REPEAT^XLFSTR(" ",25)
End DoDot:4
QUIT
+12 SET TXT=TXT_$SELECT($LENGTH(TXT)>25:",",1:"")_MIEN870
End DoDot:3
+13 IF $TRANSLATE(TXT," ","")]""
DO ADD(TXT)
+14 SET TXT=$$REPEAT^XLFSTR(" ",15)
End DoDot:2
+15 IF TXT]""
DO ADD(TXT)
SET TXT=""
End DoDot:1
+16 IF TXT]""
DO ADD(TXT)
SET TXT=""
+17 ;
+18 DO MSGTEXT^HLEVAPI1($NAME(^TMP($JOB,"HLMAIL")))
+19 ;
+20 KILL ^TMP($JOB,"HLEV REP"),^TMP($JOB,"HLMAIL")
+21 ;
+22 SET HLEVTXT(1)="MESSAGE TEXT"
+23 DO MAILIT^HLEVAPI
+24 ;
+25 QUIT
+26 ;
ADD(TXT) ; Add to global for moving into report
+1 NEW NO
+2 SET NO=$ORDER(^TMP($JOB,"HLMAIL",":"),-1)+1
+3 SET ^TMP($JOB,"HLMAIL",+NO)=TXT
+4 QUIT
+5 ;
MSG(TXT) ; Generic text displayer...
+1 WRITE !!,TXT
+2 ; Always put at least one blank row in place
WRITE !
+3 FOR
if ($Y+3)>IOSL
QUIT
WRITE !
+4 SET X=$$BTE^HLCSMON("Press RETURN to exit... ")
+5 QUIT
+6 ;
CHECKS(IEN870,WAY,MIEN870) ; Perform various checks on queue entry...
+1 ; CTDINUM,CTSKIP,CTSTUB -- req
+2 ;->
if '$$DATA870(IEN870,WAY,MIEN870)
QUIT
+3 DO CHKSTUB(IEN870,WAY,MIEN870)
+4 DO CHKDINUM(IEN870,WAY,MIEN870)
+5 QUIT
+6 ;
DATA870(IEN870,WAY,MIEN870) ; Does record exist?
+1 ; CTSKIP,LINKNM -- req
+2 ;
+3 ; Check for existence of data here...
+4 ;->
if $GET(^HLCS(870,+IEN870,WAY,+MIEN870,0))]""
QUIT 1
+5 ;
+6 SET WAY(1)=$SELECT(WAY=1:"INCOMING",1:"OUTGOING")
+7 ;
+8 ; Has this problem already been logged?
+9 ;->
if '$$LOG^HLEVAPI2("870-SKIP","IEN870^WAY^MIEN870")
QUIT ""
+10 ;
+11 DO RECORD("SKIP",LINKNM,WAY(1),MIEN870)
+12 SET CTSKIP=CTSKIP+1
SET CTERR=CTERR+1
+13 ;
+14 QUIT ""
+15 ;
CHKSTUB(IEN870,WAY,MIEN870) ; Check if a stub record that "hangs around"
+1 ; CTSTUB,LINKNM -- req
+2 NEW DATABEF,STATUS
+3 SET STATUS=$PIECE($GET(^HLCS(870,+IEN870,+WAY,+MIEN870,0)),U,2)
+4 ;-> Stub record
if STATUS'="S"
QUIT
+5 SET WAY(1)=$SELECT(WAY=1:"INCOMING",1:"OUTGOING")
+6 SET DATABEF=$SELECT(XTMPBEF']"":"",1:$SELECT($DATA(^XTMP(XTMPBEF,+IEN870,WAY(1),+MIEN870)):1,1:""))
+7 SET ^XTMP(XTMPNOW,+IEN870,WAY(1),+MIEN870)=DATABEF
+8 ;-> Stub entry didn't exist before...
if 'DATABEF
QUIT
+9 ;
+10 ; Has this problem already been logged?
+11 ;->
if '$$LOG^HLEVAPI2("870-STUB","IEN870^WAY^MIEN870")
QUIT
+12 ;
+13 DO RECORD("STUB",LINKNM,WAY(1),MIEN870)
+14 SET CTSTUB=CTSTUB+1
SET CTERR=CTERR+1
+15 ;
+16 QUIT
+17 ;
CHKDINUM(IEN870,WAY,MIEN870) ; Check for records not DINUMd for log link
+1 ; CTDINUM,LINKNM -- req
+2 ;
+3 ; {01/16/04 - Call to $$LOG^HLEVAPI2 removed. See REPDINUM call.}
+4 ;
+5 NEW IEN
+6 ;
+7 ; DINUM check here...
+8 ;->
SET IEN=+$GET(^HLCS(870,+IEN870,WAY,+MIEN870,0))
if IEN=MIEN870
QUIT
+9 ;
+10 SET WAY(1)=$SELECT(WAY=1:"INCOMING",1:"OUTGOING")
+11 ;
+12 ; New occurence, so record error...
+13 DO RECORD("DINUM",LINKNM,WAY(1),MIEN870)
+14 SET CTDINUM=CTDINUM+1
SET CTERR=CTERR+1
+15 ;
+16 QUIT
+17 ;
RECORD(PROBL,LINKNM,WAY,MIEN870) ; Record for later inclusion in report
+1 ;
+2 ; Required: At least two levels passed...
+3 ;->
SET PROBL=$GET(PROBL)
if PROBL']""
QUIT
+4 ;->
SET LINKNM=$GET(LINKNM)
if LINKNM']""
QUIT
+5 SET LEVEL=2
+6 SET WAY=$GET(WAY)
IF WAY]""
SET LEVEL=3
+7 SET MIEN870=$GET(MIEN870)
IF MIEN870]""
SET LEVEL=4
+8 ;
+9 ; Data level set...
+10 IF LEVEL=4
SET ^TMP($JOB,"HLEV REP",PROBL,LINKNM,WAY,MIEN870)=""
+11 IF LEVEL=3
SET ^TMP($JOB,"HLEV REP",PROBL,LINKNM,WAY)=""
+12 IF LEVEL=2
SET ^TMP($JOB,"HLEV REP",PROBL,LINKNM)=""
+13 ;
+14 ; Total level sets...
+15 IF LEVEL=4
SET ^TMP($JOB,"HLEV REP",PROBL,LINKNM,WAY)=$GET(^TMP($JOB,"HLEV REP",PROBL,LINKNM,WAY))+1
+16 IF LEVEL=3
SET ^TMP($JOB,"HLEV REP",PROBL,LINKNM)=$GET(^TMP($JOB,"HLEV REP",PROBL,LINKNM))+1
+17 SET ^TMP($JOB,"HLEV REP",PROBL)=$GET(^TMP($JOB,"HLEV REP",PROBL))+1
+18 SET ^TMP($JOB,"HLEV REP")=$GET(^TMP($JOB,"HLEV REP"))+1
+19 ;
+20 QUIT
+21 ;
+22 ; ====================================================================
+23 ;
CORRECT ; Correct a stub entry in HLCS(870)...
+1 NEW IEN870,MIEN870,WAY
+2 DO HD
DO EX
+3 ;->
SET WAY=$$WAY
IF WAY']""
Begin DoDot:1
+4 DO MSG("Exiting... ")
End DoDot:1
QUIT
+5 WRITE !
+6 ;->
SET IEN870=$$LINK
IF IEN870']""
Begin DoDot:1
+7 DO MSG("No link selected. Start again... ")
End DoDot:1
QUIT
CONT WRITE !
+1 ;->
SET MIEN870=$$MIEN870(IEN870,WAY)
IF MIEN870'>0
Begin DoDot:1
+2 DO MSG("No stub entry exists for link.")
End DoDot:1
QUIT
+3 WRITE !!,"Stub record# ",MIEN870," found. It's status is about to be changed to DONE..."
+4 WRITE !
+5 ;->
if '$$YN^HLCSRPT4("OK to correct","Yes")
QUIT
+6 DO FIX(IEN870,WAY,MIEN870,"D")
+7 WRITE " fixed... "
+8 WRITE !
+9 ;->
if $$BTE^HLCSMON("Press RETURN to continue searching... ")
QUIT
+10 ;->
GOTO CONT
+11 ;
FIX(IEN870,WAY,MIEN870,STAT) ; Fix stub record...
+1 NEW DA,DIE,DR,SUBDD
+2 SET DIE="^HLCS(870,"_IEN870_","_WAY_","
+3 SET DA(1)=IEN870
SET DA=+MIEN870
+4 SET DR=$SELECT($GET(STAT)]"":"1///"_STAT,1:1)
+5 DO ^DIE
+6 QUIT
+7 ;
WAY() ; In or Out?
+1 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
+2 SET DIR(0)="SO^1:Search the IN QUEUE;2:Search the OUT QUEUE"
+3 SET DIR("A")="Select the QUEUE to search"
+4 DO ^DIR
+5 ;->
if $DATA(DIRUT)!($DATA(DTOUT))!($DATA(DUOUT))
QUIT ""
+6 QUIT $SELECT(+Y:+Y,1:"")
+7 ;
LINK() ; Which 870 entry?
+1 NEW DIC,X,Y
+2 SET DIC=870
SET DIC(0)="AEMQ"
SET DIC("A")="Select LOGICAL LINK: "
+3 DO ^DIC
+4 QUIT $SELECT(+Y:+Y,1:"")
+5 ;
MIEN870(IEN870,WAY) ; Search for stub record...
+1 NEW CT,IEN,IOINHI,IOINORM,MIEN870,STATUS,X
+2 ;
+3 SET X="IOINHI;IOINORM"
DO ENDR^%ZISS
+4 ;
+5 WRITE !,IOINHI,"Searching for stub records...",IOINORM
+6 SET CT=0
SET IEN=0
SET MIEN870=0
+7 FOR
SET IEN=$ORDER(^HLCS(870,+IEN870,WAY,IEN))
if IEN'>0!(MIEN870)
QUIT
Begin DoDot:1
+8 SET CT=CT+1
if '(CT#500)
WRITE "."
+9 ;->
SET DATA=$GET(^HLCS(870,+IEN870,WAY,IEN,0))
if $PIECE(DATA,U,2)'="S"
QUIT
+10 ; If not hung, and is a proper stub entry, it will disappear
HANG 15
+11 ;->
SET DATA=$GET(^HLCS(870,+IEN870,WAY,IEN,0))
if $PIECE(DATA,U,2)'="S"
QUIT
+12 SET MIEN870=IEN
End DoDot:1
+13 ;
+14 QUIT MIEN870
+15 ;
HD WRITE @IOF,$$CJ^XLFSTR("Stub Record Correction",IOM)
+1 WRITE !,$$REPEAT^XLFSTR("=",IOM)
+2 QUIT
+3 ;
EX NEW I,T
FOR I=1:1
SET T=$TEXT(EX+I)
if T'[";;"
QUIT
WRITE !,$PIECE(T,";;",2,99)
+1 ;;Occasionally, entry's in the IN QUEUE and the OUT QUEUE of the HL Logical
+2 ;;Link file (#870) get stuck in the STUB status. (Stub records have the STATUS
+3 ;;field set to STUB.) When this occurs, no further processing of the queue
+4 ;;occurs.
+5 ;;
+6 ;;This utility loops through the IN QUEUE or the OUT QUEUE of a logical link
+7 ;;looking for stub records. (Stub records have the STATUS field set to STUB.)
+8 ;;When it finds a stub record it requests permission to set the STATUS field to
+9 ;;DONE.
+10 QUIT
+11 ;
EOR ;HLEVX000 - VistA HL7 Event Monitor Code ;5/30/03 15:25
