Routine: LRPXSXRL

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

 ;===============================================================

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

FRESH ; deletes all Lab, Micro, and AP ^PXRMINDX(63 indexes

 K ^PXRMINDX(63)                                 ; dbia 4114

CLEANL ;

 D BMES^XPDUTL("Cleaning up old Lab entries")

 D FRESH ; remove all lab indexes

RESETAP ; reindex AP

 D BMES^XPDUTL("Reindex Anatomic Pathology Data")

 D REMOVE("A")

 D AP^LRPXSXRA

RESETMI ; reindex Micro

 D BMES^XPDUTL("Reindex Microbiology Data")

 D REMOVE("M")

 D MICRO^LRPXSXRB

RESETAM ; reindex AP and Micro

 D RESETAP

 D RESETMI

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)

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

LRPXSXRL.m