LRPXSXRA ; SLC/PKR - Build indexes for Lab Anatomic Path. ;10/9/03 14:24
;;5.2;LAB SERVICE;**295**;Sep 27, 1994
Q
;===============================================================
AP ; from LRPXSXRL
;Build the indexes for LAB DATA - ANATOMIC PATHOLOGY.
N ANUMS,DATE,DFN,END,ENTRIES,ETIOL,GLOBAL,I,II,III,ICD,ICDX,IND,ITEM
N LRDFN,ORGAN,NE,NERROR,NODE,SNOMED,SPEC,START,SUB,SUBS,TEMP,TENP,TEXT
K ANUMS
;Dont leave any old stuff around.
S GLOBAL=$$GET1^DID(63,"","","GLOBAL NAME")_"""AP"")"
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 - ANATOMIC PATH")
S TEXT="There are "_ENTRIES_" entries to process."
D MES^XPDUTL(TEXT)
S START=$H
S (IND,NE,NERROR)=0
D AANUMS^LRPXSXRB(.ANUMS)
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)
. D CYEMSP(LRDFN,DFN,.ANUMS) ; cytology, electron microscopy, sugrical path
. S DATE=$$DOD^LRPXAPIU(DFN) I 'DATE Q ; date of death
. I '+$G(^LR(LRDFN,"AU")) Q ; date of autopsy
. I '($P(^LR(LRDFN,"AU"),U,3)&($P(^("AU"),U,15))) Q ; autopsy comp/released
. S SPEC=0
. F S SPEC=$O(^LR(LRDFN,33,SPEC)) Q:SPEC<1 D
.. I '$L($P($G(^LR(LRDFN,33,SPEC,0)),U)) Q
.. S ITEM="A;S;1."_$$UP($P(^LR(LRDFN,33,SPEC,0),U))
.. S NODE=LRDFN_";33;"_SPEC_";0"
.. D APSET(DFN,ITEM,DATE,NODE)
. S ICD=0
. F S ICD=$O(^LR(LRDFN,80,ICD)) Q:ICD<1 D
.. S ICDX=+$G(^LR(LRDFN,80,ICD,0))
.. I 'ICDX Q
.. S ITEM="A;I;"_ICDX
.. S NODE=LRDFN_";80;"_ICD_";0"
.. D APSET(DFN,ITEM,DATE,NODE)
. S I=0
. F S I=$O(^LR(LRDFN,"AY",I)) Q:I<1 D
.. S ORGAN=+$G(^LR(LRDFN,"AY",I,0))
.. I 'ORGAN Q
.. S ITEM="A;O;"_ORGAN
.. S NODE=LRDFN_";AY;"_I_";0"
.. D APSET(DFN,ITEM,DATE,NODE)
.. F SUBS="1D","2M","3F","4P" D
... S SUB=+SUBS
... S II=0
... F S II=$O(^LR(LRDFN,"AY",I,SUB,II)) Q:II<1 D
.... S SNOMED=+$G(^LR(LRDFN,"AY",I,SUB,II,0))
.... I 'SNOMED Q
.... S ITEM="A;"_$E(SUBS,2)_";"_SNOMED
.... S NODE=LRDFN_";AY;"_I_";"_SUB_";"_II_";0"
.... D APSET(DFN,ITEM,DATE,NODE)
.... I SUB'=2 Q
.... S III=0
.... F S III=$O(^LR(LRDFN,"AY",I,SUB,II,1,III)) Q:III<1 D
..... S ETIOL=+$G(^LR(LRDFN,"AY",I,SUB,II,1,III,0))
..... I 'ETIOL Q
..... S ITEM="A;E;"_ETIOL
..... S NODE=LRDFN_";AY;"_I_";"_SUB_";"_II_";1;"_III_";0"
..... D APSET(DFN,ITEM,DATE,NODE)
S TEXT=NE_" LAB DATA (AP) 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
Q
;
CYEMSP(LRDFN,DFN,ANUMS) ;
N ACC,APSUB,DATE,ERR,I,ICD,ICDX,ITEM,LRIDT,NODE,ORGAN,PREP,SPEC
N TEST,TESTS K TESTS
F APSUB="CY","EM","SP" D
. I '$D(^LR(LRDFN,APSUB,0)) Q
. S LRIDT=0
. F S LRIDT=$O(^LR(LRDFN,APSUB,LRIDT)) Q:LRIDT<1 D
.. S DATE=+$G(^LR(LRDFN,APSUB,LRIDT,0))
.. I 'DATE Q
.. S DATE=9999999-LRIDT ; use for multiple entries on a date
.. I '($P(^LR(LRDFN,APSUB,LRIDT,0),U,3)&($P(^(0),U,11))) Q
.. S SPEC=0
.. F S SPEC=$O(^LR(LRDFN,APSUB,LRIDT,.1,SPEC)) Q:SPEC<1 D
... I '$L($P($G(^LR(LRDFN,APSUB,LRIDT,.1,SPEC,0)),U)) Q
... S ITEM="A;S;1."_$$UP($P(^LR(LRDFN,APSUB,LRIDT,.1,SPEC,0),U))
... S NODE=LRDFN_";"_APSUB_";"_LRIDT_";.1;"_SPEC_";0"
... D APSET(DFN,ITEM,DATE,NODE)
... S PREP=0
... F S PREP=$O(^LR(LRDFN,APSUB,LRIDT,.1,SPEC,1,PREP)) Q:PREP<1 D
.... S TEST=0
.... F S TEST=$O(^LR(LRDFN,APSUB,LRIDT,.1,SPEC,1,PREP,1,TEST)) Q:TEST<1 D
..... S TEST=+$G(^LR(LRDFN,APSUB,LRIDT,.1,SPEC,1,PREP,1,TEST,0))
..... I 'TEST Q
..... S ITEM="A;T;"_TEST
..... S NODE=LRDFN_";"_APSUB_";"_LRIDT_";.1;"_SPEC_";1;"_PREP_";1;"_TEST_";0"
..... D APSET(DFN,ITEM,DATE,NODE)
.. ; S ACC=$P(^LR(LRDFN,APSUB,LRIDT,0),U,6) ; do not use tests from acc
.. ; I $L(ACC) D
.. ; . S NODE=LRDFN_";"_APSUB_";"_LRIDT_";0"
.. ; . D ACC^LRPXSXRB(.TESTS,ACC,DATE,.ANUMS,.ERR)
.. ; . I 'ERR D
.. ; .. S TEST=0
.. ; .. F S TEST=$O(TESTS(TEST)) Q:TEST<1 D
.. ; ... S ITEM="A;T;"_TEST
.. ; ... D APSET(DFN,ITEM,DATE,NODE)
.. S ICD=0
.. F S ICD=$O(^LR(LRDFN,APSUB,LRIDT,3,ICD)) Q:ICD<1 D
... S ICDX=+$G(^LR(LRDFN,APSUB,LRIDT,3,ICD,0))
... I 'ICDX Q
... S ITEM="A;I;"_ICDX
... S NODE=LRDFN_";"_APSUB_";"_LRIDT_";3;"_ICD_";0"
... D APSET(DFN,ITEM,DATE,NODE)
.. S I=0
.. F S I=$O(^LR(LRDFN,APSUB,LRIDT,2,I)) Q:I<1 D
... S ORGAN=+$G(^LR(LRDFN,APSUB,LRIDT,2,I,0))
... I 'ORGAN Q
... S ITEM="A;O;"_ORGAN
... S NODE=LRDFN_";"_APSUB_";"_LRIDT_";2;"_I_";0"
... D APSET(DFN,ITEM,DATE,NODE)
... D SNOMED(LRDFN,DFN,LRIDT,DATE,APSUB,I)
Q
;
SNOMED(LRDFN,DFN,LRIDT,DATE,APSUB,I) ;
N ETIOL,II,III,ITEM,NODE,SNOMED,SUB,SUBS
F SUBS="1D","2M","3F","4P" D
. S SUB=+SUBS
. S II=0
. F S II=$O(^LR(LRDFN,APSUB,LRIDT,2,I,SUB,II)) Q:II<1 D
.. S SNOMED=+$G(^LR(LRDFN,APSUB,LRIDT,2,I,SUB,II,0))
.. I 'SNOMED Q
.. S ITEM="A;"_$E(SUBS,2)_";"_SNOMED
.. S NODE=LRDFN_";"_APSUB_";"_LRIDT_";2;"_I_";"_SUB_";"_II_";0"
.. D APSET(DFN,ITEM,DATE,NODE)
.. I SUB'=2 Q
.. S III=0
.. F S III=$O(^LR(LRDFN,APSUB,LRIDT,2,I,SUB,II,1,III)) Q:III<1 D
... S ETIOL=+$G(^LR(LRDFN,APSUB,LRIDT,2,I,SUB,II,1,III,0))
... I 'ETIOL Q
... S ITEM="A;E;"_ETIOL
... S NODE=LRDFN_";"_APSUB_";"_LRIDT_";2;"_I_";"_SUB_";"_II_";1;"_III_";0"
... D APSET(DFN,ITEM,DATE,NODE)
Q
;
UP(X) Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
;
APSET(DFN,ITEM,DATE,NODE) ;
I '$P(ITEM,";",3) D
. N ETEXT
. S ETEXT=NODE_" missing test"
. D ADDERROR^PXRMSXRM("LR(AP",ETEXT,.NERROR) ; dbia 4113
E D
. D SLAB^LRPX(DFN,DATE,ITEM,NODE)
. S NE=NE+1
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRPXSXRA 5930 printed Sep 23, 2025@19:55:21 Page 2
LRPXSXRA ; SLC/PKR - Build indexes for Lab Anatomic Path. ;10/9/03 14:24
+1 ;;5.2;LAB SERVICE;**295**;Sep 27, 1994
+2 QUIT
+3 ;===============================================================
AP ; from LRPXSXRL
+1 ;Build the indexes for LAB DATA - ANATOMIC PATHOLOGY.
+2 NEW ANUMS,DATE,DFN,END,ENTRIES,ETIOL,GLOBAL,I,II,III,ICD,ICDX,IND,ITEM
+3 NEW LRDFN,ORGAN,NE,NERROR,NODE,SNOMED,SPEC,START,SUB,SUBS,TEMP,TENP,TEXT
+4 KILL ANUMS
+5 ;Dont leave any old stuff around.
+6 SET GLOBAL=$$GET1^DID(63,"","","GLOBAL NAME")_"""AP"")"
+7 SET ENTRIES=$PIECE(^LR(0),U,4)
+8 SET TENP=ENTRIES/10
+9 SET TENP=+$PIECE(TENP,".",1)
+10 IF TENP<1
SET TENP=1
+11 DO BMES^XPDUTL("Building indexes for LAB DATA - ANATOMIC PATH")
+12 SET TEXT="There are "_ENTRIES_" entries to process."
+13 DO MES^XPDUTL(TEXT)
+14 SET START=$HOROLOG
+15 SET (IND,NE,NERROR)=0
+16 DO AANUMS^LRPXSXRB(.ANUMS)
+17 SET LRDFN=.9
+18 FOR
SET LRDFN=$ORDER(^LR(LRDFN))
if LRDFN<1
QUIT
Begin DoDot:1
+19 SET TEMP=$GET(^LR(LRDFN,0))
+20 IF $PIECE(TEMP,U,2)'=2
QUIT
+21 SET DFN=+$PIECE(TEMP,U,3)
+22 IF LRDFN'=$$LRDFN^LRPXAPIU(DFN)
QUIT
+23 SET IND=IND+1
+24 IF IND#TENP=0
Begin DoDot:2
+25 SET TEXT="Processing entry "_IND
+26 DO MES^XPDUTL(TEXT)
End DoDot:2
+27 ; cytology, electron microscopy, sugrical path
DO CYEMSP(LRDFN,DFN,.ANUMS)
+28 ; date of death
SET DATE=$$DOD^LRPXAPIU(DFN)
IF 'DATE
QUIT
+29 ; date of autopsy
IF '+$GET(^LR(LRDFN,"AU"))
QUIT
+30 ; autopsy comp/released
IF '($PIECE(^LR(LRDFN,"AU"),U,3)&($PIECE(^("AU"),U,15)))
QUIT
+31 SET SPEC=0
+32 FOR
SET SPEC=$ORDER(^LR(LRDFN,33,SPEC))
if SPEC<1
QUIT
Begin DoDot:2
+33 IF '$LENGTH($PIECE($GET(^LR(LRDFN,33,SPEC,0)),U))
QUIT
+34 SET ITEM="A;S;1."_$$UP($PIECE(^LR(LRDFN,33,SPEC,0),U))
+35 SET NODE=LRDFN_";33;"_SPEC_";0"
+36 DO APSET(DFN,ITEM,DATE,NODE)
End DoDot:2
+37 SET ICD=0
+38 FOR
SET ICD=$ORDER(^LR(LRDFN,80,ICD))
if ICD<1
QUIT
Begin DoDot:2
+39 SET ICDX=+$GET(^LR(LRDFN,80,ICD,0))
+40 IF 'ICDX
QUIT
+41 SET ITEM="A;I;"_ICDX
+42 SET NODE=LRDFN_";80;"_ICD_";0"
+43 DO APSET(DFN,ITEM,DATE,NODE)
End DoDot:2
+44 SET I=0
+45 FOR
SET I=$ORDER(^LR(LRDFN,"AY",I))
if I<1
QUIT
Begin DoDot:2
+46 SET ORGAN=+$GET(^LR(LRDFN,"AY",I,0))
+47 IF 'ORGAN
QUIT
+48 SET ITEM="A;O;"_ORGAN
+49 SET NODE=LRDFN_";AY;"_I_";0"
+50 DO APSET(DFN,ITEM,DATE,NODE)
+51 FOR SUBS="1D","2M","3F","4P"
Begin DoDot:3
+52 SET SUB=+SUBS
+53 SET II=0
+54 FOR
SET II=$ORDER(^LR(LRDFN,"AY",I,SUB,II))
if II<1
QUIT
Begin DoDot:4
+55 SET SNOMED=+$GET(^LR(LRDFN,"AY",I,SUB,II,0))
+56 IF 'SNOMED
QUIT
+57 SET ITEM="A;"_$EXTRACT(SUBS,2)_";"_SNOMED
+58 SET NODE=LRDFN_";AY;"_I_";"_SUB_";"_II_";0"
+59 DO APSET(DFN,ITEM,DATE,NODE)
+60 IF SUB'=2
QUIT
+61 SET III=0
+62 FOR
SET III=$ORDER(^LR(LRDFN,"AY",I,SUB,II,1,III))
if III<1
QUIT
Begin DoDot:5
+63 SET ETIOL=+$GET(^LR(LRDFN,"AY",I,SUB,II,1,III,0))
+64 IF 'ETIOL
QUIT
+65 SET ITEM="A;E;"_ETIOL
+66 SET NODE=LRDFN_";AY;"_I_";"_SUB_";"_II_";1;"_III_";0"
+67 DO APSET(DFN,ITEM,DATE,NODE)
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+68 SET TEXT=NE_" LAB DATA (AP) results indexed."
+69 DO MES^XPDUTL(TEXT)
+70 SET END=$HOROLOG
+71 ; dbia 4113
DO DETIME^PXRMSXRM(START,END)
+72 ;If there were errors send a message.
+73 ; dbia 4113
IF NERROR>0
DO ERRMSG^PXRMSXRM(NERROR,GLOBAL)
+74 ;Send a MailMan message with the results.
+75 ; dbia 4113
DO COMMSG^PXRMSXRM(GLOBAL,START,END,NE,NERROR)
+76 QUIT
+77 ;
CYEMSP(LRDFN,DFN,ANUMS) ;
+1 NEW ACC,APSUB,DATE,ERR,I,ICD,ICDX,ITEM,LRIDT,NODE,ORGAN,PREP,SPEC
+2 NEW TEST,TESTS
KILL TESTS
+3 FOR APSUB="CY","EM","SP"
Begin DoDot:1
+4 IF '$DATA(^LR(LRDFN,APSUB,0))
QUIT
+5 SET LRIDT=0
+6 FOR
SET LRIDT=$ORDER(^LR(LRDFN,APSUB,LRIDT))
if LRIDT<1
QUIT
Begin DoDot:2
+7 SET DATE=+$GET(^LR(LRDFN,APSUB,LRIDT,0))
+8 IF 'DATE
QUIT
+9 ; use for multiple entries on a date
SET DATE=9999999-LRIDT
+10 IF '($PIECE(^LR(LRDFN,APSUB,LRIDT,0),U,3)&($PIECE(^(0),U,11)))
QUIT
+11 SET SPEC=0
+12 FOR
SET SPEC=$ORDER(^LR(LRDFN,APSUB,LRIDT,.1,SPEC))
if SPEC<1
QUIT
Begin DoDot:3
+13 IF '$LENGTH($PIECE($GET(^LR(LRDFN,APSUB,LRIDT,.1,SPEC,0)),U))
QUIT
+14 SET ITEM="A;S;1."_$$UP($PIECE(^LR(LRDFN,APSUB,LRIDT,.1,SPEC,0),U))
+15 SET NODE=LRDFN_";"_APSUB_";"_LRIDT_";.1;"_SPEC_";0"
+16 DO APSET(DFN,ITEM,DATE,NODE)
+17 SET PREP=0
+18 FOR
SET PREP=$ORDER(^LR(LRDFN,APSUB,LRIDT,.1,SPEC,1,PREP))
if PREP<1
QUIT
Begin DoDot:4
+19 SET TEST=0
+20 FOR
SET TEST=$ORDER(^LR(LRDFN,APSUB,LRIDT,.1,SPEC,1,PREP,1,TEST))
if TEST<1
QUIT
Begin DoDot:5
+21 SET TEST=+$GET(^LR(LRDFN,APSUB,LRIDT,.1,SPEC,1,PREP,1,TEST,0))
+22 IF 'TEST
QUIT
+23 SET ITEM="A;T;"_TEST
+24 SET NODE=LRDFN_";"_APSUB_";"_LRIDT_";.1;"_SPEC_";1;"_PREP_";1;"_TEST_";0"
+25 DO APSET(DFN,ITEM,DATE,NODE)
End DoDot:5
End DoDot:4
End DoDot:3
+26 ; S ACC=$P(^LR(LRDFN,APSUB,LRIDT,0),U,6) ; do not use tests from acc
+27 ; I $L(ACC) D
+28 ; . S NODE=LRDFN_";"_APSUB_";"_LRIDT_";0"
+29 ; . D ACC^LRPXSXRB(.TESTS,ACC,DATE,.ANUMS,.ERR)
+30 ; . I 'ERR D
+31 ; .. S TEST=0
+32 ; .. F S TEST=$O(TESTS(TEST)) Q:TEST<1 D
+33 ; ... S ITEM="A;T;"_TEST
+34 ; ... D APSET(DFN,ITEM,DATE,NODE)
+35 SET ICD=0
+36 FOR
SET ICD=$ORDER(^LR(LRDFN,APSUB,LRIDT,3,ICD))
if ICD<1
QUIT
Begin DoDot:3
+37 SET ICDX=+$GET(^LR(LRDFN,APSUB,LRIDT,3,ICD,0))
+38 IF 'ICDX
QUIT
+39 SET ITEM="A;I;"_ICDX
+40 SET NODE=LRDFN_";"_APSUB_";"_LRIDT_";3;"_ICD_";0"
+41 DO APSET(DFN,ITEM,DATE,NODE)
End DoDot:3
+42 SET I=0
+43 FOR
SET I=$ORDER(^LR(LRDFN,APSUB,LRIDT,2,I))
if I<1
QUIT
Begin DoDot:3
+44 SET ORGAN=+$GET(^LR(LRDFN,APSUB,LRIDT,2,I,0))
+45 IF 'ORGAN
QUIT
+46 SET ITEM="A;O;"_ORGAN
+47 SET NODE=LRDFN_";"_APSUB_";"_LRIDT_";2;"_I_";0"
+48 DO APSET(DFN,ITEM,DATE,NODE)
+49 DO SNOMED(LRDFN,DFN,LRIDT,DATE,APSUB,I)
End DoDot:3
End DoDot:2
End DoDot:1
+50 QUIT
+51 ;
SNOMED(LRDFN,DFN,LRIDT,DATE,APSUB,I) ;
+1 NEW ETIOL,II,III,ITEM,NODE,SNOMED,SUB,SUBS
+2 FOR SUBS="1D","2M","3F","4P"
Begin DoDot:1
+3 SET SUB=+SUBS
+4 SET II=0
+5 FOR
SET II=$ORDER(^LR(LRDFN,APSUB,LRIDT,2,I,SUB,II))
if II<1
QUIT
Begin DoDot:2
+6 SET SNOMED=+$GET(^LR(LRDFN,APSUB,LRIDT,2,I,SUB,II,0))
+7 IF 'SNOMED
QUIT
+8 SET ITEM="A;"_$EXTRACT(SUBS,2)_";"_SNOMED
+9 SET NODE=LRDFN_";"_APSUB_";"_LRIDT_";2;"_I_";"_SUB_";"_II_";0"
+10 DO APSET(DFN,ITEM,DATE,NODE)
+11 IF SUB'=2
QUIT
+12 SET III=0
+13 FOR
SET III=$ORDER(^LR(LRDFN,APSUB,LRIDT,2,I,SUB,II,1,III))
if III<1
QUIT
Begin DoDot:3
+14 SET ETIOL=+$GET(^LR(LRDFN,APSUB,LRIDT,2,I,SUB,II,1,III,0))
+15 IF 'ETIOL
QUIT
+16 SET ITEM="A;E;"_ETIOL
+17 SET NODE=LRDFN_";"_APSUB_";"_LRIDT_";2;"_I_";"_SUB_";"_II_";1;"_III_";0"
+18 DO APSET(DFN,ITEM,DATE,NODE)
End DoDot:3
End DoDot:2
End DoDot:1
+19 QUIT
+20 ;
UP(X) QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+1 ;
APSET(DFN,ITEM,DATE,NODE) ;
+1 IF '$PIECE(ITEM,";",3)
Begin DoDot:1
+2 NEW ETEXT
+3 SET ETEXT=NODE_" missing test"
+4 ; dbia 4113
DO ADDERROR^PXRMSXRM("LR(AP",ETEXT,.NERROR)
End DoDot:1
+5 IF '$TEST
Begin DoDot:1
+6 DO SLAB^LRPX(DFN,DATE,ITEM,NODE)
+7 SET NE=NE+1
End DoDot:1
+8 QUIT
+9 ;
