LRPXSXRL.m

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 ---LRPXSXRL   3693     printed  Apr 23, 2025@18:33:44                                                                                                                                                                                                    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