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