source: FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLEVX000.m@ 1754

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