LRPXRM ;SLC/STAFF Lab reminder index for micro and ap ;5/6/04 13:21
;;5.2;LAB SERVICE;**295**;Sep 27, 1994
;
UPDATE(LRDFN,SUB,LRIDT) ; update Micro and AP xrefs in ^PXRMINDX(63
; from LRAPDA,LRAPDSR,LRMIEDZ,LRMIEDZ2,LRMISTF1,LRMIV,LRMIV1,LRMIV2
; - ^TMP("LRPX",$J, is used for processing any edits of Micro or AP data:
; - All results "AR" are copied when the patient's sample is edited.
; - Indexes of the patient's "PDI" are copied before "B" edits.
; - Indexes created from the "AR" data provide an index after "A" edits.
; - "A" and "B" are compared to determine what has been added "ADD"
; and what has been deleted "DEL".
; - The ^PXRMINDX(63 indexes are added or deleted using "ADD" and "DEL".
N DATE,DFN K ^TMP("LRPX",$J)
S LRIDT=+$G(LRIDT)
S DFN=$$DFN^LRPXAPIU(+$G(LRDFN)) I 'DFN Q
I SUB="AU" D Q
. S DATE=$$DOD^LRPXAPIU(DFN) I 'DATE Q
. I '+$G(^LR(LRDFN,"AU")) Q
. I '($P(^LR(LRDFN,"AU"),U,3)&($P(^("AU"),U,15))) Q
. M ^TMP("LRPX",$J,"B")=^PXRMINDX(63,"PDI",DFN,DATE)
. M ^TMP("LRPX",$J,"AR","AY")=^LR(LRDFN,"AY")
. M ^TMP("LRPX",$J,"AR",80)=^LR(LRDFN,80)
. M ^TMP("LRPX",$J,"AR",33)=^LR(LRDFN,33)
. D AP(DFN,LRDFN,DATE,LRIDT,SUB)
. K ^TMP("LRPX",$J)
S DATE=$$LRIDT^LRPXAPIU(LRIDT)
M ^TMP("LRPX",$J,"B")=^PXRMINDX(63,"PDI",DFN,DATE)
I SUB="MI" D
. M ^TMP("LRPX",$J,"AR")=^LR(LRDFN,SUB,LRIDT)
. D MICRO(DFN,LRDFN,DATE,LRIDT)
E D
. M ^TMP("LRPX",$J,"AR",0)=^LR(LRDFN,SUB,LRIDT,0)
. M ^TMP("LRPX",$J,"AR",.1)=^LR(LRDFN,SUB,LRIDT,.1)
. M ^TMP("LRPX",$J,"AR",2)=^LR(LRDFN,SUB,LRIDT,2)
. M ^TMP("LRPX",$J,"AR",3)=^LR(LRDFN,SUB,LRIDT,3)
. D AP(DFN,LRDFN,DATE,LRIDT,SUB)
K ^TMP("LRPX",$J)
Q
;
MICRO(DFN,LRDFN,DATE,LRIDT) ;
N AB,ABDN,ACC,ITEM,NODE,ORG,ORGNUM,SPEC,SUB,TB,TBDN,TEST,TESTS K TESTS
S ITEM=0
F S ITEM=$O(^TMP("LRPX",$J,"B",ITEM)) Q:ITEM="" D
. I $E(ITEM)'="M" K ^TMP("LRPX",$J,"B",ITEM)
I '+$G(^TMP("LRPX",$J,"AR",0)) Q
I '$$MIVER(LRDFN,LRIDT) Q
S SPEC=+$P(^TMP("LRPX",$J,"AR",0),U,5)
I 'SPEC Q
S ITEM="M;S;"_SPEC
S NODE=LRDFN_";MI;"_LRIDT_";0"
D TMPSET(ITEM,NODE)
S ACC=$P(^TMP("LRPX",$J,"AR",0),U,6)
I $L(ACC) D
. D ACCY^LRPXAPI(.TESTS,ACC,DATE)
. I $O(TESTS(0)) D
.. S TEST=0
.. F S TEST=+$O(TESTS(TEST)) Q:TEST<1 D
... S ITEM="M;T;"_TEST
... D TMPSET(ITEM,NODE)
I $G(^TMP("LRPX",$J,"AR",1)) D
. S ORGNUM=0
. F S ORGNUM=$O(^TMP("LRPX",$J,"AR",3,ORGNUM)) Q:ORGNUM<1 D
.. S ORG=+$G(^TMP("LRPX",$J,"AR",3,ORGNUM,0))
.. I 'ORG Q
.. S ITEM="M;O;"_ORG
.. S NODE=LRDFN_";MI;"_LRIDT_";3;"_ORGNUM_";0"
.. D TMPSET(ITEM,NODE)
.. S ABDN=1
.. F S ABDN=$O(^TMP("LRPX",$J,"AR",3,ORGNUM,ABDN)) Q:ABDN<1 D
... S AB=$$AB^LRPXAPIU(ABDN)
... I 'AB Q
... S ITEM="M;A;"_AB
... S NODE=LRDFN_";MI;"_LRIDT_";3;"_ORGNUM_";"_ABDN
... D TMPSET(ITEM,NODE)
F SUB=6,9,12,17 D
. I '$G(^TMP("LRPX",$J,"AR",(SUB-1))) Q
. S ORGNUM=0
. F S ORGNUM=$O(^TMP("LRPX",$J,"AR",SUB,ORGNUM)) Q:ORGNUM<1 D
.. S ORG=+$G(^TMP("LRPX",$J,"AR",SUB,ORGNUM,0))
.. I 'ORG Q
.. S ITEM="M;O;"_ORG
.. S NODE=LRDFN_";MI;"_LRIDT_";"_SUB_";"_ORGNUM_";0"
.. D TMPSET(ITEM,NODE)
.. I SUB'=12 Q
.. S TBDN=2
.. F S TBDN=$O(^TMP("LRPX",$J,"AR",12,ORGNUM,TBDN)) Q:TBDN<2 D
... S TB=$$TB^LRPXAPIU(TBDN)
... I '$L(TB) Q
... S ITEM="M;M;"_TB
... S NODE=LRDFN_";MI;"_LRIDT_";12;"_ORGNUM_";"_TBDN
... D TMPSET(ITEM,NODE)
D CKDEL
D CKADD
D DEL(DFN,DATE)
D ADD(DFN,DATE)
Q
;
MIVER(LRDFN,LRIDT) ; $$(lrdfn,lridt) -> 1 if any portion of micro is verified
N OK,SUB
S OK=0
F SUB=1,5,8,11,16 D Q:OK
. I $G(^LR(LRDFN,"MI",LRIDT,SUB)) S OK=1
Q OK
;
AP(DFN,LRDFN,DATE,LRIDT,SUB) ;
N ITEM
I '$$APVERIFY^LRPXAPI(LRDFN,LRIDT,SUB) Q
S ITEM=0
F S ITEM=$O(^TMP("LRPX",$J,"B",ITEM)) Q:ITEM="" D
. I $E(ITEM)'="A" K ^TMP("LRPX",$J,"B",ITEM)
I SUB="AU" D AUTOPSY(LRDFN)
E D CYEMSP(LRDFN,LRIDT,DATE,SUB) ; cyto, electron micro, surg path
D CKDEL
D CKADD
D DEL(DFN,DATE)
D ADD(DFN,DATE)
Q
;
AUTOPSY(LRDFN) ;
N ETIOL,I,II,III,ICD,ICDX,ITEM,NODE,ORGAN,SNOMED,SPEC,SUB,SUBS
S SPEC=0
F S SPEC=$O(^TMP("LRPX",$J,"AR",33,SPEC)) Q:SPEC<1 D
. I '$L($P($G(^TMP("LRPX",$J,"AR",33,SPEC,0)),U)) Q
. S ITEM="A;S;1."_$P(^TMP("LRPX",$J,"AR",33,SPEC,0),U)
. S NODE=LRDFN_";33;"_SPEC_";0"
. D TMPSET(ITEM,NODE)
S ICD=0
F S ICD=$O(^TMP("LRPX",$J,"AR",80,ICD)) Q:ICD<1 D
. S ICDX=+$G(^TMP("LRPX",$J,"AR",80,ICD,0))
. I 'ICDX Q
. S ITEM="A;I;"_ICDX
. S NODE=LRDFN_";80;"_ICD_";0"
. D TMPSET(ITEM,NODE)
S I=0
F S I=$O(^TMP("LRPX",$J,"AR","AY",I)) Q:I<1 D
. S ORGAN=+$G(^TMP("LRPX",$J,"AR","AY",I,0))
. I 'ORGAN Q
. S ITEM="A;O;"_ORGAN
. S NODE=LRDFN_";AY;"_I_";0"
. D TMPSET(ITEM,NODE)
. F SUBS="1D","2M","3F","4P" D
.. S SUB=+SUBS
.. S II=0
.. F S II=$O(^TMP("LRPX",$J,"AR","AY",I,SUB,II)) Q:II<1 D
... S SNOMED=+$G(^TMP("LRPX",$J,"AR","AY",I,SUB,II,0))
... I 'SNOMED Q
... S ITEM="A;"_$E(SUBS,2)_";"_SNOMED
... S NODE=LRDFN_";AY;"_I_";"_SUB_";"_II_";0"
... D TMPSET(ITEM,NODE)
... I SUB'=2 Q
... S III=0
... F S III=$O(^TMP("LRPX",$J,"AR","AY",I,SUB,II,1,III)) Q:III<1 D
.... S ETIOL=+$G(^TMP("LRPX",$J,"AR","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 TMPSET(ITEM,NODE)
Q
;
CYEMSP(LRDFN,LRIDT,DATE,SUB) ;
N ACC,I,ICD,ICDX,ITEM,NODE,ORGAN,PREP,SPEC,TEST,TESTS K TESTS
I '($P($G(^TMP("LRPX",$J,"AR",0)),U,3)&($P($G(^(0)),U,11))) Q
S SPEC=0
F S SPEC=$O(^TMP("LRPX",$J,"AR",.1,SPEC)) Q:SPEC<1 D
. I '$L($P($G(^TMP("LRPX",$J,"AR",.1,SPEC,0)),U)) Q
. S ITEM="A;S;1."_$$UP^XLFSTR($P(^TMP("LRPX",$J,"AR",.1,SPEC,0),U))
. S NODE=LRDFN_";"_SUB_";"_LRIDT_";.1;"_SPEC_";0"
. D TMPSET(ITEM,NODE)
. S PREP=0
. F S PREP=$O(^TMP("LRPX",$J,"AR",.1,SPEC,1,PREP)) Q:PREP<1 D
.. S TEST=0
.. F S TEST=$O(^TMP("LRPX",$J,"AR",.1,SPEC,1,PREP,1,TEST)) Q:TEST<1 D
... S TEST=+$G(^TMP("LRPX",$J,"AR",.1,SPEC,1,PREP,1,TEST,0))
... I 'TEST Q
... S ITEM="A;T;"_TEST
... S NODE=LRDFN_";"_SUB_";"_LRIDT_";.1;"_SPEC_";1;"_PREP_";1;"_TEST_";0"
... D TMPSET(ITEM,NODE)
; S ACC=$P(^TMP("LRPX",$J,"AR",0),U,6) ; do not use tests on acc
; I $L(ACC) D
; . S NODE=LRDFN_";"_SUB_";"_LRIDT_";0"
; . D ACCY^LRPXAPI(.TESTS,ACC,DATE)
; . I $O(TESTS(0)) D
; .. S TEST=0
; .. F S TEST=$O(TESTS(TEST)) Q:TEST<1 D
; ... S ITEM="A;T;"_TEST
; ... D TMPSET(ITEM,NODE)
S ICD=0
F S ICD=$O(^TMP("LRPX",$J,"AR",3,ICD)) Q:ICD<1 D
. S ICDX=+$G(^TMP("LRPX",$J,"AR",3,ICD,0))
. I 'ICDX Q
. S ITEM="A;I;"_ICDX
. S NODE=LRDFN_";"_SUB_";"_LRIDT_";3;"_ICD_";0"
. D TMPSET(ITEM,NODE)
S I=0
F S I=$O(^TMP("LRPX",$J,"AR",2,I)) Q:I<1 D
. S ORGAN=+$G(^TMP("LRPX",$J,"AR",2,I,0))
. I 'ORGAN Q
. S ITEM="A;O;"_ORGAN
. S NODE=LRDFN_";"_SUB_";"_LRIDT_";2;"_I_";0"
. D TMPSET(ITEM,NODE)
. D SNOMED(LRDFN,LRIDT,SUB,I)
Q
;
SNOMED(LRDFN,LRIDT,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(^TMP("LRPX",$J,"AR",2,I,SUB,II)) Q:II<1 D
.. S SNOMED=+$G(^TMP("LRPX",$J,"AR",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 TMPSET(ITEM,NODE)
.. I SUB'=2 Q
.. S III=0
.. F S III=$O(^TMP("LRPX",$J,"AR",2,I,SUB,II,1,III)) Q:III<1 D
... S ETIOL=+$G(^TMP("LRPX",$J,"AR",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 TMPSET(ITEM,NODE)
Q
;
TMPSET(ITEM,NODE) ;
S ^TMP("LRPX",$J,"A",ITEM,NODE)=""
Q
;
CKDEL ;
N ITEM,NODE
S ITEM=""
F S ITEM=$O(^TMP("LRPX",$J,"B",ITEM)) Q:ITEM="" D
. S NODE=""
. F S NODE=$O(^TMP("LRPX",$J,"B",ITEM,NODE)) Q:NODE="" D
.. I $D(^TMP("LRPX",$J,"A",ITEM,NODE)) Q
.. S ^TMP("LRPX",$J,"DEL",ITEM,NODE)=""
Q
;
CKADD ;
N ITEM,NODE
S ITEM=""
F S ITEM=$O(^TMP("LRPX",$J,"A",ITEM)) Q:ITEM="" D
. S NODE=""
. F S NODE=$O(^TMP("LRPX",$J,"A",ITEM,NODE)) Q:NODE="" D
.. I $D(^TMP("LRPX",$J,"B",ITEM,NODE)) Q
.. S ^TMP("LRPX",$J,"ADD",ITEM,NODE)=""
Q
;
DEL(DFN,DATE) ;
N ITEM,NODE
S ITEM=""
F S ITEM=$O(^TMP("LRPX",$J,"DEL",ITEM)) Q:ITEM="" D
. S NODE=""
. F S NODE=$O(^TMP("LRPX",$J,"DEL",ITEM,NODE)) Q:NODE="" D
.. D KLAB^LRPX(DFN,DATE,ITEM,NODE)
Q
;
ADD(DFN,DATE) ;
N ITEM,NODE
S ITEM=""
F S ITEM=$O(^TMP("LRPX",$J,"ADD",ITEM)) Q:ITEM="" D
. S NODE=""
. F S NODE=$O(^TMP("LRPX",$J,"ADD",ITEM,NODE)) Q:NODE="" D
.. D SLAB^LRPX(DFN,DATE,ITEM,NODE)
.. ; D TIMESTMP^LRLOG(DFN,$P(NODE,";",2),DATE,DUZ) ; *** future lab patch
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRPXRM 8678 printed Sep 23, 2025@19:55:20 Page 2
LRPXRM ;SLC/STAFF Lab reminder index for micro and ap ;5/6/04 13:21
+1 ;;5.2;LAB SERVICE;**295**;Sep 27, 1994
+2 ;
UPDATE(LRDFN,SUB,LRIDT) ; update Micro and AP xrefs in ^PXRMINDX(63
+1 ; from LRAPDA,LRAPDSR,LRMIEDZ,LRMIEDZ2,LRMISTF1,LRMIV,LRMIV1,LRMIV2
+2 ; - ^TMP("LRPX",$J, is used for processing any edits of Micro or AP data:
+3 ; - All results "AR" are copied when the patient's sample is edited.
+4 ; - Indexes of the patient's "PDI" are copied before "B" edits.
+5 ; - Indexes created from the "AR" data provide an index after "A" edits.
+6 ; - "A" and "B" are compared to determine what has been added "ADD"
+7 ; and what has been deleted "DEL".
+8 ; - The ^PXRMINDX(63 indexes are added or deleted using "ADD" and "DEL".
+9 NEW DATE,DFN
KILL ^TMP("LRPX",$JOB)
+10 SET LRIDT=+$GET(LRIDT)
+11 SET DFN=$$DFN^LRPXAPIU(+$GET(LRDFN))
IF 'DFN
QUIT
+12 IF SUB="AU"
Begin DoDot:1
+13 SET DATE=$$DOD^LRPXAPIU(DFN)
IF 'DATE
QUIT
+14 IF '+$GET(^LR(LRDFN,"AU"))
QUIT
+15 IF '($PIECE(^LR(LRDFN,"AU"),U,3)&($PIECE(^("AU"),U,15)))
QUIT
+16 MERGE ^TMP("LRPX",$JOB,"B")=^PXRMINDX(63,"PDI",DFN,DATE)
+17 MERGE ^TMP("LRPX",$JOB,"AR","AY")=^LR(LRDFN,"AY")
+18 MERGE ^TMP("LRPX",$JOB,"AR",80)=^LR(LRDFN,80)
+19 MERGE ^TMP("LRPX",$JOB,"AR",33)=^LR(LRDFN,33)
+20 DO AP(DFN,LRDFN,DATE,LRIDT,SUB)
+21 KILL ^TMP("LRPX",$JOB)
End DoDot:1
QUIT
+22 SET DATE=$$LRIDT^LRPXAPIU(LRIDT)
+23 MERGE ^TMP("LRPX",$JOB,"B")=^PXRMINDX(63,"PDI",DFN,DATE)
+24 IF SUB="MI"
Begin DoDot:1
+25 MERGE ^TMP("LRPX",$JOB,"AR")=^LR(LRDFN,SUB,LRIDT)
+26 DO MICRO(DFN,LRDFN,DATE,LRIDT)
End DoDot:1
+27 IF '$TEST
Begin DoDot:1
+28 MERGE ^TMP("LRPX",$JOB,"AR",0)=^LR(LRDFN,SUB,LRIDT,0)
+29 MERGE ^TMP("LRPX",$JOB,"AR",.1)=^LR(LRDFN,SUB,LRIDT,.1)
+30 MERGE ^TMP("LRPX",$JOB,"AR",2)=^LR(LRDFN,SUB,LRIDT,2)
+31 MERGE ^TMP("LRPX",$JOB,"AR",3)=^LR(LRDFN,SUB,LRIDT,3)
+32 DO AP(DFN,LRDFN,DATE,LRIDT,SUB)
End DoDot:1
+33 KILL ^TMP("LRPX",$JOB)
+34 QUIT
+35 ;
MICRO(DFN,LRDFN,DATE,LRIDT) ;
+1 NEW AB,ABDN,ACC,ITEM,NODE,ORG,ORGNUM,SPEC,SUB,TB,TBDN,TEST,TESTS
KILL TESTS
+2 SET ITEM=0
+3 FOR
SET ITEM=$ORDER(^TMP("LRPX",$JOB,"B",ITEM))
if ITEM=""
QUIT
Begin DoDot:1
+4 IF $EXTRACT(ITEM)'="M"
KILL ^TMP("LRPX",$JOB,"B",ITEM)
End DoDot:1
+5 IF '+$GET(^TMP("LRPX",$JOB,"AR",0))
QUIT
+6 IF '$$MIVER(LRDFN,LRIDT)
QUIT
+7 SET SPEC=+$PIECE(^TMP("LRPX",$JOB,"AR",0),U,5)
+8 IF 'SPEC
QUIT
+9 SET ITEM="M;S;"_SPEC
+10 SET NODE=LRDFN_";MI;"_LRIDT_";0"
+11 DO TMPSET(ITEM,NODE)
+12 SET ACC=$PIECE(^TMP("LRPX",$JOB,"AR",0),U,6)
+13 IF $LENGTH(ACC)
Begin DoDot:1
+14 DO ACCY^LRPXAPI(.TESTS,ACC,DATE)
+15 IF $ORDER(TESTS(0))
Begin DoDot:2
+16 SET TEST=0
+17 FOR
SET TEST=+$ORDER(TESTS(TEST))
if TEST<1
QUIT
Begin DoDot:3
+18 SET ITEM="M;T;"_TEST
+19 DO TMPSET(ITEM,NODE)
End DoDot:3
End DoDot:2
End DoDot:1
+20 IF $GET(^TMP("LRPX",$JOB,"AR",1))
Begin DoDot:1
+21 SET ORGNUM=0
+22 FOR
SET ORGNUM=$ORDER(^TMP("LRPX",$JOB,"AR",3,ORGNUM))
if ORGNUM<1
QUIT
Begin DoDot:2
+23 SET ORG=+$GET(^TMP("LRPX",$JOB,"AR",3,ORGNUM,0))
+24 IF 'ORG
QUIT
+25 SET ITEM="M;O;"_ORG
+26 SET NODE=LRDFN_";MI;"_LRIDT_";3;"_ORGNUM_";0"
+27 DO TMPSET(ITEM,NODE)
+28 SET ABDN=1
+29 FOR
SET ABDN=$ORDER(^TMP("LRPX",$JOB,"AR",3,ORGNUM,ABDN))
if ABDN<1
QUIT
Begin DoDot:3
+30 SET AB=$$AB^LRPXAPIU(ABDN)
+31 IF 'AB
QUIT
+32 SET ITEM="M;A;"_AB
+33 SET NODE=LRDFN_";MI;"_LRIDT_";3;"_ORGNUM_";"_ABDN
+34 DO TMPSET(ITEM,NODE)
End DoDot:3
End DoDot:2
End DoDot:1
+35 FOR SUB=6,9,12,17
Begin DoDot:1
+36 IF '$GET(^TMP("LRPX",$JOB,"AR",(SUB-1)))
QUIT
+37 SET ORGNUM=0
+38 FOR
SET ORGNUM=$ORDER(^TMP("LRPX",$JOB,"AR",SUB,ORGNUM))
if ORGNUM<1
QUIT
Begin DoDot:2
+39 SET ORG=+$GET(^TMP("LRPX",$JOB,"AR",SUB,ORGNUM,0))
+40 IF 'ORG
QUIT
+41 SET ITEM="M;O;"_ORG
+42 SET NODE=LRDFN_";MI;"_LRIDT_";"_SUB_";"_ORGNUM_";0"
+43 DO TMPSET(ITEM,NODE)
+44 IF SUB'=12
QUIT
+45 SET TBDN=2
+46 FOR
SET TBDN=$ORDER(^TMP("LRPX",$JOB,"AR",12,ORGNUM,TBDN))
if TBDN<2
QUIT
Begin DoDot:3
+47 SET TB=$$TB^LRPXAPIU(TBDN)
+48 IF '$LENGTH(TB)
QUIT
+49 SET ITEM="M;M;"_TB
+50 SET NODE=LRDFN_";MI;"_LRIDT_";12;"_ORGNUM_";"_TBDN
+51 DO TMPSET(ITEM,NODE)
End DoDot:3
End DoDot:2
End DoDot:1
+52 DO CKDEL
+53 DO CKADD
+54 DO DEL(DFN,DATE)
+55 DO ADD(DFN,DATE)
+56 QUIT
+57 ;
MIVER(LRDFN,LRIDT) ; $$(lrdfn,lridt) -> 1 if any portion of micro is verified
+1 NEW OK,SUB
+2 SET OK=0
+3 FOR SUB=1,5,8,11,16
Begin DoDot:1
+4 IF $GET(^LR(LRDFN,"MI",LRIDT,SUB))
SET OK=1
End DoDot:1
if OK
QUIT
+5 QUIT OK
+6 ;
AP(DFN,LRDFN,DATE,LRIDT,SUB) ;
+1 NEW ITEM
+2 IF '$$APVERIFY^LRPXAPI(LRDFN,LRIDT,SUB)
QUIT
+3 SET ITEM=0
+4 FOR
SET ITEM=$ORDER(^TMP("LRPX",$JOB,"B",ITEM))
if ITEM=""
QUIT
Begin DoDot:1
+5 IF $EXTRACT(ITEM)'="A"
KILL ^TMP("LRPX",$JOB,"B",ITEM)
End DoDot:1
+6 IF SUB="AU"
DO AUTOPSY(LRDFN)
+7 ; cyto, electron micro, surg path
IF '$TEST
DO CYEMSP(LRDFN,LRIDT,DATE,SUB)
+8 DO CKDEL
+9 DO CKADD
+10 DO DEL(DFN,DATE)
+11 DO ADD(DFN,DATE)
+12 QUIT
+13 ;
AUTOPSY(LRDFN) ;
+1 NEW ETIOL,I,II,III,ICD,ICDX,ITEM,NODE,ORGAN,SNOMED,SPEC,SUB,SUBS
+2 SET SPEC=0
+3 FOR
SET SPEC=$ORDER(^TMP("LRPX",$JOB,"AR",33,SPEC))
if SPEC<1
QUIT
Begin DoDot:1
+4 IF '$LENGTH($PIECE($GET(^TMP("LRPX",$JOB,"AR",33,SPEC,0)),U))
QUIT
+5 SET ITEM="A;S;1."_$PIECE(^TMP("LRPX",$JOB,"AR",33,SPEC,0),U)
+6 SET NODE=LRDFN_";33;"_SPEC_";0"
+7 DO TMPSET(ITEM,NODE)
End DoDot:1
+8 SET ICD=0
+9 FOR
SET ICD=$ORDER(^TMP("LRPX",$JOB,"AR",80,ICD))
if ICD<1
QUIT
Begin DoDot:1
+10 SET ICDX=+$GET(^TMP("LRPX",$JOB,"AR",80,ICD,0))
+11 IF 'ICDX
QUIT
+12 SET ITEM="A;I;"_ICDX
+13 SET NODE=LRDFN_";80;"_ICD_";0"
+14 DO TMPSET(ITEM,NODE)
End DoDot:1
+15 SET I=0
+16 FOR
SET I=$ORDER(^TMP("LRPX",$JOB,"AR","AY",I))
if I<1
QUIT
Begin DoDot:1
+17 SET ORGAN=+$GET(^TMP("LRPX",$JOB,"AR","AY",I,0))
+18 IF 'ORGAN
QUIT
+19 SET ITEM="A;O;"_ORGAN
+20 SET NODE=LRDFN_";AY;"_I_";0"
+21 DO TMPSET(ITEM,NODE)
+22 FOR SUBS="1D","2M","3F","4P"
Begin DoDot:2
+23 SET SUB=+SUBS
+24 SET II=0
+25 FOR
SET II=$ORDER(^TMP("LRPX",$JOB,"AR","AY",I,SUB,II))
if II<1
QUIT
Begin DoDot:3
+26 SET SNOMED=+$GET(^TMP("LRPX",$JOB,"AR","AY",I,SUB,II,0))
+27 IF 'SNOMED
QUIT
+28 SET ITEM="A;"_$EXTRACT(SUBS,2)_";"_SNOMED
+29 SET NODE=LRDFN_";AY;"_I_";"_SUB_";"_II_";0"
+30 DO TMPSET(ITEM,NODE)
+31 IF SUB'=2
QUIT
+32 SET III=0
+33 FOR
SET III=$ORDER(^TMP("LRPX",$JOB,"AR","AY",I,SUB,II,1,III))
if III<1
QUIT
Begin DoDot:4
+34 SET ETIOL=+$GET(^TMP("LRPX",$JOB,"AR","AY",I,SUB,II,1,III,0))
+35 IF 'ETIOL
QUIT
+36 SET ITEM="A;E;"_ETIOL
+37 SET NODE=LRDFN_";AY;"_I_";"_SUB_";"_II_";1;"_III_";0"
+38 DO TMPSET(ITEM,NODE)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+39 QUIT
+40 ;
CYEMSP(LRDFN,LRIDT,DATE,SUB) ;
+1 NEW ACC,I,ICD,ICDX,ITEM,NODE,ORGAN,PREP,SPEC,TEST,TESTS
KILL TESTS
+2 IF '($PIECE($GET(^TMP("LRPX",$JOB,"AR",0)),U,3)&($PIECE($GET(^(0)),U,11)))
QUIT
+3 SET SPEC=0
+4 FOR
SET SPEC=$ORDER(^TMP("LRPX",$JOB,"AR",.1,SPEC))
if SPEC<1
QUIT
Begin DoDot:1
+5 IF '$LENGTH($PIECE($GET(^TMP("LRPX",$JOB,"AR",.1,SPEC,0)),U))
QUIT
+6 SET ITEM="A;S;1."_$$UP^XLFSTR($PIECE(^TMP("LRPX",$JOB,"AR",.1,SPEC,0),U))
+7 SET NODE=LRDFN_";"_SUB_";"_LRIDT_";.1;"_SPEC_";0"
+8 DO TMPSET(ITEM,NODE)
+9 SET PREP=0
+10 FOR
SET PREP=$ORDER(^TMP("LRPX",$JOB,"AR",.1,SPEC,1,PREP))
if PREP<1
QUIT
Begin DoDot:2
+11 SET TEST=0
+12 FOR
SET TEST=$ORDER(^TMP("LRPX",$JOB,"AR",.1,SPEC,1,PREP,1,TEST))
if TEST<1
QUIT
Begin DoDot:3
+13 SET TEST=+$GET(^TMP("LRPX",$JOB,"AR",.1,SPEC,1,PREP,1,TEST,0))
+14 IF 'TEST
QUIT
+15 SET ITEM="A;T;"_TEST
+16 SET NODE=LRDFN_";"_SUB_";"_LRIDT_";.1;"_SPEC_";1;"_PREP_";1;"_TEST_";0"
+17 DO TMPSET(ITEM,NODE)
End DoDot:3
End DoDot:2
End DoDot:1
+18 ; S ACC=$P(^TMP("LRPX",$J,"AR",0),U,6) ; do not use tests on acc
+19 ; I $L(ACC) D
+20 ; . S NODE=LRDFN_";"_SUB_";"_LRIDT_";0"
+21 ; . D ACCY^LRPXAPI(.TESTS,ACC,DATE)
+22 ; . I $O(TESTS(0)) D
+23 ; .. S TEST=0
+24 ; .. F S TEST=$O(TESTS(TEST)) Q:TEST<1 D
+25 ; ... S ITEM="A;T;"_TEST
+26 ; ... D TMPSET(ITEM,NODE)
+27 SET ICD=0
+28 FOR
SET ICD=$ORDER(^TMP("LRPX",$JOB,"AR",3,ICD))
if ICD<1
QUIT
Begin DoDot:1
+29 SET ICDX=+$GET(^TMP("LRPX",$JOB,"AR",3,ICD,0))
+30 IF 'ICDX
QUIT
+31 SET ITEM="A;I;"_ICDX
+32 SET NODE=LRDFN_";"_SUB_";"_LRIDT_";3;"_ICD_";0"
+33 DO TMPSET(ITEM,NODE)
End DoDot:1
+34 SET I=0
+35 FOR
SET I=$ORDER(^TMP("LRPX",$JOB,"AR",2,I))
if I<1
QUIT
Begin DoDot:1
+36 SET ORGAN=+$GET(^TMP("LRPX",$JOB,"AR",2,I,0))
+37 IF 'ORGAN
QUIT
+38 SET ITEM="A;O;"_ORGAN
+39 SET NODE=LRDFN_";"_SUB_";"_LRIDT_";2;"_I_";0"
+40 DO TMPSET(ITEM,NODE)
+41 DO SNOMED(LRDFN,LRIDT,SUB,I)
End DoDot:1
+42 QUIT
+43 ;
SNOMED(LRDFN,LRIDT,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(^TMP("LRPX",$JOB,"AR",2,I,SUB,II))
if II<1
QUIT
Begin DoDot:2
+6 SET SNOMED=+$GET(^TMP("LRPX",$JOB,"AR",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 TMPSET(ITEM,NODE)
+11 IF SUB'=2
QUIT
+12 SET III=0
+13 FOR
SET III=$ORDER(^TMP("LRPX",$JOB,"AR",2,I,SUB,II,1,III))
if III<1
QUIT
Begin DoDot:3
+14 SET ETIOL=+$GET(^TMP("LRPX",$JOB,"AR",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 TMPSET(ITEM,NODE)
End DoDot:3
End DoDot:2
End DoDot:1
+19 QUIT
+20 ;
TMPSET(ITEM,NODE) ;
+1 SET ^TMP("LRPX",$JOB,"A",ITEM,NODE)=""
+2 QUIT
+3 ;
CKDEL ;
+1 NEW ITEM,NODE
+2 SET ITEM=""
+3 FOR
SET ITEM=$ORDER(^TMP("LRPX",$JOB,"B",ITEM))
if ITEM=""
QUIT
Begin DoDot:1
+4 SET NODE=""
+5 FOR
SET NODE=$ORDER(^TMP("LRPX",$JOB,"B",ITEM,NODE))
if NODE=""
QUIT
Begin DoDot:2
+6 IF $DATA(^TMP("LRPX",$JOB,"A",ITEM,NODE))
QUIT
+7 SET ^TMP("LRPX",$JOB,"DEL",ITEM,NODE)=""
End DoDot:2
End DoDot:1
+8 QUIT
+9 ;
CKADD ;
+1 NEW ITEM,NODE
+2 SET ITEM=""
+3 FOR
SET ITEM=$ORDER(^TMP("LRPX",$JOB,"A",ITEM))
if ITEM=""
QUIT
Begin DoDot:1
+4 SET NODE=""
+5 FOR
SET NODE=$ORDER(^TMP("LRPX",$JOB,"A",ITEM,NODE))
if NODE=""
QUIT
Begin DoDot:2
+6 IF $DATA(^TMP("LRPX",$JOB,"B",ITEM,NODE))
QUIT
+7 SET ^TMP("LRPX",$JOB,"ADD",ITEM,NODE)=""
End DoDot:2
End DoDot:1
+8 QUIT
+9 ;
DEL(DFN,DATE) ;
+1 NEW ITEM,NODE
+2 SET ITEM=""
+3 FOR
SET ITEM=$ORDER(^TMP("LRPX",$JOB,"DEL",ITEM))
if ITEM=""
QUIT
Begin DoDot:1
+4 SET NODE=""
+5 FOR
SET NODE=$ORDER(^TMP("LRPX",$JOB,"DEL",ITEM,NODE))
if NODE=""
QUIT
Begin DoDot:2
+6 DO KLAB^LRPX(DFN,DATE,ITEM,NODE)
End DoDot:2
End DoDot:1
+7 QUIT
+8 ;
ADD(DFN,DATE) ;
+1 NEW ITEM,NODE
+2 SET ITEM=""
+3 FOR
SET ITEM=$ORDER(^TMP("LRPX",$JOB,"ADD",ITEM))
if ITEM=""
QUIT
Begin DoDot:1
+4 SET NODE=""
+5 FOR
SET NODE=$ORDER(^TMP("LRPX",$JOB,"ADD",ITEM,NODE))
if NODE=""
QUIT
Begin DoDot:2
+6 DO SLAB^LRPX(DFN,DATE,ITEM,NODE)
+7 ; D TIMESTMP^LRLOG(DFN,$P(NODE,";",2),DATE,DUZ) ; *** future lab patch
End DoDot:2
End DoDot:1
+8 QUIT
+9 ;
