- 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 Jan 18, 2025@03:20:23 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 ;