LRPXSXRL ;VA/SLC/PKR - Build indexes for Lab. ;9/27/03 22:37
;;5.2;LAB SERVICE;**1030,1031**;NOV 01, 1997
;
;;VA LR Patch(s): 295
;
Q
;===============================================================
LAB ; this entry point is called to rebuild ALL Lab indexes in ^PXRMINDX(63
; dbia 4247
;Build the indexes for LAB DATA.
; ----- BEGIN IHS/OIT/MKK - LR*5.2*1030
; RPMS Lab does not use Clinical Reminders.
; None of the following code will be used.
; Q
; ----- END IHS/OIT/MKK - LR*5.2*1030
;
Q:'$$PATCH^BLRUTIL4("PXRM*1.5*12") ; IHS/MSC/MKK - LR*5.2*1031
;
N DAE,DAS,DAT,DATE,DFN,DNODE,END,ENTRIES,ETEXT,GLOBAL,IND
N LRDFN,LRDN,LRIDT,NE,NERROR
N START,TEMP,TENP,TEST,TEXT
K ^TMP("LRPXTEST",$J)
;Dont leave any old stuff around.
D CLEANL
S GLOBAL=$$GET1^DID(63,"","","GLOBAL NAME")_"""CH"")"
S NERROR=0
S ENTRIES=$P(^LR(0),U,4)
S TENP=ENTRIES/10
S TENP=+$P(TENP,".",1)
I TENP<1 S TENP=1
D BMES^XPDUTL("Building indexes for LAB DATA - CH")
S TEXT="There are "_ENTRIES_" entries to process."
D MES^XPDUTL(TEXT)
S START=$H
S (IND,NE)=0
K ^TMP("LRPXSXRL",$J)
S TEST=0
F S TEST=$O(^LAB(60,TEST)) Q:TEST<1 D ; preset values (lrdn)=test#
. S DNODE=$P($G(^LAB(60,TEST,0)),U,5)
. I $P(DNODE,";")'="CH" Q
. I $P(DNODE,";",3)'=1 Q
. S LRDN=+$P(DNODE,";",2)
. I 'LRDN Q
. S ^TMP("LRPXSXRL",$J,LRDN)=TEST_U_$D(^TMP("LRPXSXRL",$J,LRDN))
S LRDFN=.9
F S LRDFN=$O(^LR(LRDFN)) Q:LRDFN<1 D
. S TEMP=$G(^LR(LRDFN,0))
. I $P(TEMP,U,2)'=2 Q
. S DFN=+$P(TEMP,U,3)
. I LRDFN'=$$LRDFN^LRPXAPIU(DFN) Q
. S IND=IND+1
. I IND#TENP=0 D
.. S TEXT="Processing entry "_IND
.. D MES^XPDUTL(TEXT)
. S LRIDT=0
. F S LRIDT=$O(^LR(LRDFN,"CH",LRIDT)) Q:LRIDT<1 D
.. I '$P($G(^LR(LRDFN,"CH",LRIDT,0)),U,3) Q ; check for completed
.. S DAT=LRDFN_";CH;"_LRIDT
.. S DATE=9999999-LRIDT
.. S LRDN=1
.. F S LRDN=$O(^LR(LRDFN,"CH",LRIDT,LRDN)) Q:LRDN<1 D
... S DAS=DAT_";"_LRDN
... S TEMP=^LR(LRDFN,"CH",LRIDT,LRDN)
... S TEST=+$P($P(TEMP,U,3),"!",6) ; get test, use ^LR node
... I 'TEST D ; if not available on ^LR node
.... I $P($G(^TMP("LRPXSXRL",$J,LRDN)),U,2) D ; if duplicates, use file 60
..... S TEST=+$O(^LAB(60,"C","CH;"_$G(LRDN)_";1",0))
.... E S TEST=+$G(^TMP("LRPXSXRL",$J,LRDN)) ; otherwise, use preset value
... I 'TEST D
.... S DAE=LRDFN_","_"""CH"""_","_LRIDT_","_LRDN
.... S ETEXT=DAE_" No lab test"
.... I $D(^TMP("LRPXTEST",$J,LRDN)) Q
.... ; D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR) ; dbia 4113 ; IHS/OIT/MKK - LR*5.2*1030 - Commented out for XINDEX
.... S ^TMP("LRPXTEST",$J,LRDN)=""
... E D
.... D SLAB^LRPX(DFN,DATE,TEST,DAS)
.... S NE=NE+1
K ^TMP("LRPXSXRL",$J),^TMP("LRPXTEST",$J)
S TEXT=NE_" LAB DATA (CH) results indexed."
D MES^XPDUTL(TEXT)
S END=$H
;
D DETIME^PXRMSXRM(START,END) ; dbia 4113
;If there were errors send a message.
I NERROR>0 D ERRMSG^PXRMSXRM(NERROR,GLOBAL) ; dbia 4113
;Send a MailMan message with the results.
D COMMSG^PXRMSXRM(GLOBAL,START,END,NE,NERROR) ; dbia 4113
;
D AP^LRPXSXRA
D MICRO^LRPXSXRB
Q
;
FRESH ; deletes all Lab, Micro, and AP ^PXRMINDX(63 indexes
K ^PXRMINDX(63) ; dbia 4114
Q
;
CLEANL ;
D BMES^XPDUTL("Cleaning up old Lab entries")
D FRESH ; remove all lab indexes
Q
;
RESETAP ; reindex AP
D BMES^XPDUTL("Reindex Anatomic Pathology Data")
D REMOVE("A")
D AP^LRPXSXRA
Q
;
RESETMI ; reindex Micro
D BMES^XPDUTL("Reindex Microbiology Data")
D REMOVE("M")
D MICRO^LRPXSXRB
Q
;
RESETAM ; reindex AP and Micro
D RESETAP
D RESETMI
Q
;
REMOVE(TYPE) ; remove these types of indexes
N DATE,DFN,ITEM,REF,STOP
S STOP=TYPE_"Z"
S ITEM=TYPE
F S ITEM=$O(^PXRMINDX(63,"IP",ITEM)) Q:ITEM="" Q:ITEM]STOP D
. S DFN=0
. F S DFN=$O(^PXRMINDX(63,"IP",ITEM,DFN)) Q:DFN<1 D
.. S DATE=0
.. F S DATE=$O(^PXRMINDX(63,"IP",ITEM,DFN,DATE)) Q:DATE<1 D
... S REF=""
... F S REF=$O(^PXRMINDX(63,"IP",ITEM,DFN,DATE,REF)) Q:REF="" D
.... D KLAB^LRPX(DFN,DATE,ITEM,REF)
Q
LRPXSXRL ;VA/SLC/PKR - Build indexes for Lab. ;9/27/03 22:37
+1 ;;5.2;LAB SERVICE;**1030,1031**;NOV 01, 1997
+2 ;
+3 ;;VA LR Patch(s): 295
+4 ;
+5 QUIT
+6 ;===============================================================
LAB ; this entry point is called to rebuild ALL Lab indexes in ^PXRMINDX(63
+1 ; dbia 4247
+2 ;Build the indexes for LAB DATA.
+3 ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1030
+4 ; RPMS Lab does not use Clinical Reminders.
+5 ; None of the following code will be used.
+6 ; Q
+7 ; ----- END IHS/OIT/MKK - LR*5.2*1030
+8 ;
+9 ; IHS/MSC/MKK - LR*5.2*1031
IF '$$PATCH^BLRUTIL4("PXRM*1.5*12")
QUIT
+10 ;
+11 NEW DAE,DAS,DAT,DATE,DFN,DNODE,END,ENTRIES,ETEXT,GLOBAL,IND
+12 NEW LRDFN,LRDN,LRIDT,NE,NERROR
+13 NEW START,TEMP,TENP,TEST,TEXT
+14 KILL ^TMP("LRPXTEST",$JOB)
+15 ;Dont leave any old stuff around.
+16 DO CLEANL
+17 SET GLOBAL=$$GET1^DID(63,"","","GLOBAL NAME")_"""CH"")"
+18 SET NERROR=0
+19 SET ENTRIES=$PIECE(^LR(0),U,4)
+20 SET TENP=ENTRIES/10
+21 SET TENP=+$PIECE(TENP,".",1)
+22 IF TENP<1
SET TENP=1
+23 DO BMES^XPDUTL("Building indexes for LAB DATA - CH")
+24 SET TEXT="There are "_ENTRIES_" entries to process."
+25 DO MES^XPDUTL(TEXT)
+26 SET START=$HOROLOG
+27 SET (IND,NE)=0
+28 KILL ^TMP("LRPXSXRL",$JOB)
+29 SET TEST=0
+30 ; preset values (lrdn)=test#
FOR
SET TEST=$ORDER(^LAB(60,TEST))
IF TEST<1
QUIT
Begin DoDot:1
+31 SET DNODE=$PIECE($GET(^LAB(60,TEST,0)),U,5)
+32 IF $PIECE(DNODE,";")'="CH"
QUIT
+33 IF $PIECE(DNODE,";",3)'=1
QUIT
+34 SET LRDN=+$PIECE(DNODE,";",2)
+35 IF 'LRDN
QUIT
+36 SET ^TMP("LRPXSXRL",$JOB,LRDN)=TEST_U_$DATA(^TMP("LRPXSXRL",$JOB,LRDN))
End DoDot:1
+37 SET LRDFN=.9
+38 FOR
SET LRDFN=$ORDER(^LR(LRDFN))
IF LRDFN<1
QUIT
Begin DoDot:1
+39 SET TEMP=$GET(^LR(LRDFN,0))
+40 IF $PIECE(TEMP,U,2)'=2
QUIT
+41 SET DFN=+$PIECE(TEMP,U,3)
+42 IF LRDFN'=$$LRDFN^LRPXAPIU(DFN)
QUIT
+43 SET IND=IND+1
+44 IF IND#TENP=0
Begin DoDot:2
+45 SET TEXT="Processing entry "_IND
+46 DO MES^XPDUTL(TEXT)
End DoDot:2
+47 SET LRIDT=0
+48 FOR
SET LRIDT=$ORDER(^LR(LRDFN,"CH",LRIDT))
IF LRIDT<1
QUIT
Begin DoDot:2
+49 ; check for completed
IF '$PIECE($GET(^LR(LRDFN,"CH",LRIDT,0)),U,3)
QUIT
+50 SET DAT=LRDFN_";CH;"_LRIDT
+51 SET DATE=9999999-LRIDT
+52 SET LRDN=1
+53 FOR
SET LRDN=$ORDER(^LR(LRDFN,"CH",LRIDT,LRDN))
IF LRDN<1
QUIT
Begin DoDot:3
+54 SET DAS=DAT_";"_LRDN
+55 SET TEMP=^LR(LRDFN,"CH",LRIDT,LRDN)
+56 ; get test, use ^LR node
SET TEST=+$PIECE($PIECE(TEMP,U,3),"!",6)
+57 ; if not available on ^LR node
IF 'TEST
Begin DoDot:4
+58 ; if duplicates, use file 60
IF $PIECE($GET(^TMP("LRPXSXRL",$JOB,LRDN)),U,2)
Begin DoDot:5
+59 SET TEST=+$ORDER(^LAB(60,"C","CH;"_$GET(LRDN)_";1",0))
End DoDot:5
+60 ; otherwise, use preset value
IF '$TEST
SET TEST=+$GET(^TMP("LRPXSXRL",$JOB,LRDN))
End DoDot:4
+61 IF 'TEST
Begin DoDot:4
+62 SET DAE=LRDFN_","_"""CH"""_","_LRIDT_","_LRDN
+63 SET ETEXT=DAE_" No lab test"
+64 IF $DATA(^TMP("LRPXTEST",$JOB,LRDN))
QUIT
+65 ; D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR) ; dbia 4113 ; IHS/OIT/MKK - LR*5.2*1030 - Commented out for XINDEX
+66 SET ^TMP("LRPXTEST",$JOB,LRDN)=""
End DoDot:4
+67 IF '$TEST
Begin DoDot:4
+68 DO SLAB^LRPX(DFN,DATE,TEST,DAS)
+69 SET NE=NE+1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+70 KILL ^TMP("LRPXSXRL",$JOB),^TMP("LRPXTEST",$JOB)
+71 SET TEXT=NE_" LAB DATA (CH) results indexed."
+72 DO MES^XPDUTL(TEXT)
+73 SET END=$HOROLOG
+74 ;
+75 ; dbia 4113
DO DETIME^PXRMSXRM(START,END)
+76 ;If there were errors send a message.
+77 ; dbia 4113
IF NERROR>0
DO ERRMSG^PXRMSXRM(NERROR,GLOBAL)
+78 ;Send a MailMan message with the results.
+79 ; dbia 4113
DO COMMSG^PXRMSXRM(GLOBAL,START,END,NE,NERROR)
+80 ;
+81 DO AP^LRPXSXRA
+82 DO MICRO^LRPXSXRB
+83 QUIT
+84 ;
FRESH ; deletes all Lab, Micro, and AP ^PXRMINDX(63 indexes
+1 ; dbia 4114
KILL ^PXRMINDX(63)
+2 QUIT
+3 ;
CLEANL ;
+1 DO BMES^XPDUTL("Cleaning up old Lab entries")
+2 ; remove all lab indexes
DO FRESH
+3 QUIT
+4 ;
RESETAP ; reindex AP
+1 DO BMES^XPDUTL("Reindex Anatomic Pathology Data")
+2 DO REMOVE("A")
+3 DO AP^LRPXSXRA
+4 QUIT
+5 ;
RESETMI ; reindex Micro
+1 DO BMES^XPDUTL("Reindex Microbiology Data")
+2 DO REMOVE("M")
+3 DO MICRO^LRPXSXRB
+4 QUIT
+5 ;
RESETAM ; reindex AP and Micro
+1 DO RESETAP
+2 DO RESETMI
+3 QUIT
+4 ;
REMOVE(TYPE) ; remove these types of indexes
+1 NEW DATE,DFN,ITEM,REF,STOP
+2 SET STOP=TYPE_"Z"
+3 SET ITEM=TYPE
+4 FOR
SET ITEM=$ORDER(^PXRMINDX(63,"IP",ITEM))
IF ITEM=""
QUIT
IF ITEM]STOP
QUIT
Begin DoDot:1
+5 SET DFN=0
+6 FOR
SET DFN=$ORDER(^PXRMINDX(63,"IP",ITEM,DFN))
IF DFN<1
QUIT
Begin DoDot:2
+7 SET DATE=0
+8 FOR
SET DATE=$ORDER(^PXRMINDX(63,"IP",ITEM,DFN,DATE))
IF DATE<1
QUIT
Begin DoDot:3
+9 SET REF=""
+10 FOR
SET REF=$ORDER(^PXRMINDX(63,"IP",ITEM,DFN,DATE,REF))
IF REF=""
QUIT
Begin DoDot:4
+11 DO KLAB^LRPX(DFN,DATE,ITEM,REF)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+12 QUIT
