LRPXSXRL ; SLC/PKR - Build indexes for Lab. ;9/27/03 22:37
;;5.2;LAB SERVICE;**295,445**;Sep 27, 1994;Build 6
Q
;===============================================================
LAB ; this entry point is called to rebuild ALL Lab indexes in ^PXRMINDX(63
; dbia 4247
;Build the indexes for LAB DATA.
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),"!",7) ; 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
.... 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRPXSXRL 3693 printed Dec 13, 2024@02:19:43 Page 2
LRPXSXRL ; SLC/PKR - Build indexes for Lab. ;9/27/03 22:37
+1 ;;5.2;LAB SERVICE;**295,445**;Sep 27, 1994;Build 6
+2 QUIT
+3 ;===============================================================
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 NEW DAE,DAS,DAT,DATE,DFN,DNODE,END,ENTRIES,ETEXT,GLOBAL,IND
+4 NEW LRDFN,LRDN,LRIDT,NE,NERROR
+5 NEW START,TEMP,TENP,TEST,TEXT
+6 KILL ^TMP("LRPXTEST",$JOB)
+7 ;Dont leave any old stuff around.
+8 DO CLEANL
+9 SET GLOBAL=$$GET1^DID(63,"","","GLOBAL NAME")_"""CH"")"
+10 SET NERROR=0
+11 SET ENTRIES=$PIECE(^LR(0),U,4)
+12 SET TENP=ENTRIES/10
+13 SET TENP=+$PIECE(TENP,".",1)
+14 IF TENP<1
SET TENP=1
+15 DO BMES^XPDUTL("Building indexes for LAB DATA - CH")
+16 SET TEXT="There are "_ENTRIES_" entries to process."
+17 DO MES^XPDUTL(TEXT)
+18 SET START=$HOROLOG
+19 SET (IND,NE)=0
+20 KILL ^TMP("LRPXSXRL",$JOB)
+21 SET TEST=0
+22 ; preset values (lrdn)=test#
FOR
SET TEST=$ORDER(^LAB(60,TEST))
if TEST<1
QUIT
Begin DoDot:1
+23 SET DNODE=$PIECE($GET(^LAB(60,TEST,0)),U,5)
+24 IF $PIECE(DNODE,";")'="CH"
QUIT
+25 IF $PIECE(DNODE,";",3)'=1
QUIT
+26 SET LRDN=+$PIECE(DNODE,";",2)
+27 IF 'LRDN
QUIT
+28 SET ^TMP("LRPXSXRL",$JOB,LRDN)=TEST_U_$DATA(^TMP("LRPXSXRL",$JOB,LRDN))
End DoDot:1
+29 SET LRDFN=.9
+30 FOR
SET LRDFN=$ORDER(^LR(LRDFN))
if LRDFN<1
QUIT
Begin DoDot:1
+31 SET TEMP=$GET(^LR(LRDFN,0))
+32 IF $PIECE(TEMP,U,2)'=2
QUIT
+33 SET DFN=+$PIECE(TEMP,U,3)
+34 IF LRDFN'=$$LRDFN^LRPXAPIU(DFN)
QUIT
+35 SET IND=IND+1
+36 IF IND#TENP=0
Begin DoDot:2
+37 SET TEXT="Processing entry "_IND
+38 DO MES^XPDUTL(TEXT)
End DoDot:2
+39 SET LRIDT=0
+40 FOR
SET LRIDT=$ORDER(^LR(LRDFN,"CH",LRIDT))
if LRIDT<1
QUIT
Begin DoDot:2
+41 ; check for completed
IF '$PIECE($GET(^LR(LRDFN,"CH",LRIDT,0)),U,3)
QUIT
+42 SET DAT=LRDFN_";CH;"_LRIDT
+43 SET DATE=9999999-LRIDT
+44 SET LRDN=1
+45 FOR
SET LRDN=$ORDER(^LR(LRDFN,"CH",LRIDT,LRDN))
if LRDN<1
QUIT
Begin DoDot:3
+46 SET DAS=DAT_";"_LRDN
+47 SET TEMP=^LR(LRDFN,"CH",LRIDT,LRDN)
+48 ; get test, use ^LR node
SET TEST=+$PIECE($PIECE(TEMP,U,3),"!",7)
+49 ; if not available on ^LR node
IF 'TEST
Begin DoDot:4
+50 ; if duplicates, use file 60
IF $PIECE($GET(^TMP("LRPXSXRL",$JOB,LRDN)),U,2)
Begin DoDot:5
+51 SET TEST=+$ORDER(^LAB(60,"C","CH;"_$GET(LRDN)_";1",0))
End DoDot:5
+52 ; otherwise, use preset value
IF '$TEST
SET TEST=+$GET(^TMP("LRPXSXRL",$JOB,LRDN))
End DoDot:4
+53 IF 'TEST
Begin DoDot:4
+54 SET DAE=LRDFN_","_"""CH"""_","_LRIDT_","_LRDN
+55 SET ETEXT=DAE_" No lab test"
+56 IF $DATA(^TMP("LRPXTEST",$JOB,LRDN))
QUIT
+57 ; dbia 4113
DO ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
+58 SET ^TMP("LRPXTEST",$JOB,LRDN)=""
End DoDot:4
+59 IF '$TEST
Begin DoDot:4
+60 DO SLAB^LRPX(DFN,DATE,TEST,DAS)
+61 SET NE=NE+1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+62 KILL ^TMP("LRPXSXRL",$JOB),^TMP("LRPXTEST",$JOB)
+63 SET TEXT=NE_" LAB DATA (CH) results indexed."
+64 DO MES^XPDUTL(TEXT)
+65 SET END=$HOROLOG
+66 ; dbia 4113
DO DETIME^PXRMSXRM(START,END)
+67 ;If there were errors send a message.
+68 ; dbia 4113
IF NERROR>0
DO ERRMSG^PXRMSXRM(NERROR,GLOBAL)
+69 ;Send a MailMan message with the results.
+70 ; dbia 4113
DO COMMSG^PXRMSXRM(GLOBAL,START,END,NE,NERROR)
+71 ;
+72 DO AP^LRPXSXRA
+73 DO MICRO^LRPXSXRB
+74 QUIT
+75 ;
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
