LRPXSXRB ;VA/SLC/PKR - Build indexes for Lab Microbiology. ;1/29/04 14:36
;;5.2;LAB SERVICE;**1030,1031**;NOV 01, 1997
;
;;VA LR Patch(s): 295
;
Q
;===============================================================
MICRO ; 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 - MICROBIOLOGY.
N AB,ABDN,ACC,ANUMS,DATE,DNUM,DFN,END,ENTRIES,ERR,GLOBAL,IND,ITEM
N LRDFN,LRIDT,NE,NERROR,NODE,NUM,ORG,ORGNUM,SPEC,START,SUB
N TB,TBDN,TEMP,TENP,TEST,TESTS,TEXT
K ANUMS,TESTS
;Dont leave any old stuff around.
S GLOBAL=$$GET1^DID(63,"","","GLOBAL NAME")_"""MICRO"")"
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 - MICROBIOLOGY")
S TEXT="There are "_ENTRIES_" entries to process."
D MES^XPDUTL(TEXT)
S START=$H
S (IND,NE,NERROR)=0
K ^TMP("LRPXSXRB",$J)
S NUM=0
F S NUM=$O(^LAB(62.06,NUM)) Q:NUM<1 D
. S DNUM=+$P($G(^LAB(62.06,NUM,0)),U,2)
. I DNUM'["2." Q
. I '$D(^TMP("LRPXSXRB",$J,"AB",DNUM)) S ^TMP("LRPXSXRB",$J,"AB",DNUM)=NUM
S NUM=2
F S NUM=$O(^DD(63.39,NUM)) Q:NUM<1 D ; dbia 999
. S DNUM=+$P($G(^DD(63.39,NUM,0)),U,4) ; dbia 999
. I DNUM'["2." Q
. S ^TMP("LRPXSXRB",$J,"TB",DNUM)=NUM
D AANUMS(.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)
. S LRIDT=0
. F S LRIDT=$O(^LR(LRDFN,"MI",LRIDT)) Q:LRIDT<1 D
.. S DATE=+$G(^LR(LRDFN,"MI",LRIDT,0))
.. I 'DATE Q
.. ; I '$$MIVER^LRPXRM(LRDFN,LRIDT) Q ; IHS/OIT/MKK - LR*5.2*1030 - Commented out for XINDEX
.. I '$$MIVER^LRPXRM(LRDFN,LRIDT) Q ; IHS/MSC/MKK - LR*5.2*1031
.. S SPEC=+$P(^LR(LRDFN,"MI",LRIDT,0),U,5)
.. I 'SPEC Q
.. S ITEM="M;S;"_SPEC
.. S NODE=LRDFN_";MI;"_LRIDT_";0"
.. D MISET(DFN,ITEM,DATE,NODE)
.. S ACC=$P(^LR(LRDFN,"MI",LRIDT,0),U,6)
.. I $L(ACC) D
... D ACC(.TESTS,ACC,DATE,.ANUMS,.ERR)
... I 'ERR D
.... S TEST=0
.... F S TEST=$O(TESTS(TEST)) Q:TEST<1 D
..... S ITEM="M;T;"_TEST
..... D MISET(DFN,ITEM,DATE,NODE)
.. I $G(^LR(LRDFN,"MI",LRIDT,1)) D
... S ORGNUM=0
... F S ORGNUM=$O(^LR(LRDFN,"MI",LRIDT,3,ORGNUM)) Q:ORGNUM<1 D
.... S ORG=+$G(^LR(LRDFN,"MI",LRIDT,3,ORGNUM,0))
.... I 'ORG Q
.... S ITEM="M;O;"_ORG
.... S NODE=LRDFN_";MI;"_LRIDT_";3;"_ORGNUM_";0"
.... D MISET(DFN,ITEM,DATE,NODE)
.... S ABDN=1
.... F S ABDN=$O(^LR(LRDFN,"MI",LRIDT,3,ORGNUM,ABDN)) Q:ABDN<1 D
..... S AB=+$G(^TMP("LRPXSXRB",$J,"AB",ABDN))
..... I 'AB Q
..... S ITEM="M;A;"_AB
..... S NODE=LRDFN_";MI;"_LRIDT_";3;"_ORGNUM_";"_ABDN
..... D MISET(DFN,ITEM,DATE,NODE)
.. F SUB=6,9,12,17 D
... I '$G(^LR(LRDFN,"MI",LRIDT,(SUB-1))) Q
... S ORGNUM=0
... F S ORGNUM=$O(^LR(LRDFN,"MI",LRIDT,SUB,ORGNUM)) Q:ORGNUM<1 D
.... S ORG=+$G(^LR(LRDFN,"MI",LRIDT,SUB,ORGNUM,0))
.... I 'ORG Q
.... S ITEM="M;O;"_ORG
.... S NODE=LRDFN_";MI;"_LRIDT_";"_SUB_";"_ORGNUM_";0"
.... D MISET(DFN,ITEM,DATE,NODE)
.... I SUB'=12 Q
.... S TBDN=2
.... F S TBDN=$O(^LR(LRDFN,"MI",LRIDT,12,ORGNUM,TBDN)) Q:TBDN<2 D
..... S TB=+$G(^TMP("LRPXSXRB",$J,"TB",TBDN))
..... I '$L(TB) Q
..... S ITEM="M;M;"_TB
..... S NODE=LRDFN_";MI;"_LRIDT_";12;"_ORGNUM_";"_TBDN
..... D MISET(DFN,ITEM,DATE,NODE)
K ^TMP("LRPXSXRB",$J)
S TEXT=NE_" LAB DATA (MICRO) 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
; S ^PXRMINDX(63,"GLOBAL NAME")=$P(GLOBAL,"""",1) ; dbia 4114 ; IHS/OIT/MKK - LR*5.2*1030 - Commented out for XINDEX
; S ^PXRMINDX(63,"BUILT BY")=DUZ ; dbia 4114 ; IHS/OIT/MKK - LR*5.2*1030 - Commented out for XINDEX
; S ^PXRMINDX(63,"DATE BUILT")=$$NOW^XLFDT ; dbia 4114 ; 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
S ^PXRMINDX(63,"GLOBAL NAME")=$P(GLOBAL,"""",1) ; dbia 4114 ; IHS/MSC/MKK - LR*5.2*1031 - Put back in
S ^PXRMINDX(63,"BUILT BY")=DUZ ; dbia 4114 ; IHS/MSC/MKK - LR*5.2*1031 - Put back in
S ^PXRMINDX(63,"DATE BUILT")=$$NOW^XLFDT ; dbia 4114 ; IHS/MSC/MKK - LR*5.2*1031 - Put back in
Q
;
MISET(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(MICRO",ETEXT,.NERROR) ; dbia 4113 ; IHS/OIT/MKK - LR*5.2*1030 - Commented out for XINDEX
. D ADDERROR^PXRMSXRM("LR(MICRO",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
;
AANUMS(ANUMS) ; from LRPXSXRA
; ----- 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
;
N AA,ABREV K ANUMS
S AA=0
F S AA=$O(^LRO(68,AA)) Q:AA<1 D
. S ABREV=$P($G(^LRO(68,AA,0)),U,11)
. I $L(ABREV) S ANUMS(ABREV)=AA
Q
;
ACC(TESTS,ACC,BDN,ANUMS,ERR) ; from LRPXSXRA
; ----- 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
; returns TESTS from micro accession, ACC, BDN required
; BDN is beginning date number
; ANUMS is array of accession name numbers (avoids lookup on repeated calls)
N DIC,LRAA,LRAAB,LRAD,LRAN,TEST,X,Y K DIC,TESTS
S ERR=0
I '$L($G(ACC)) S ERR=1 Q
S LRAAB=$P(ACC," ")
I LRAAB="" Q
S BDN=$E($G(BDN))
I BDN'>1 S ERR=1 Q
S LRAN=+$P(ACC," ",3)
I 'LRAN S ERR=1 Q
S LRAA=+$G(ANUMS(LRAAB))
I 'LRAA D
. S DIC=68,DIC(0)="M"
. S X=LRAAB
. D ^DIC K DIC
. S LRAA=+Y
. S ANUMS(LRAAB)=LRAA
I LRAA'>0 S ERR=1 Q
S LRAD=BDN_$P(ACC," ",2)_"0000" ; yearly acc areas are assumed
S TEST=0
F S TEST=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,TEST)) Q:TEST<1 D
. S TESTS(TEST)=TEST
Q
;
LRPXSXRB ;VA/SLC/PKR - Build indexes for Lab Microbiology. ;1/29/04 14:36
+1 ;;5.2;LAB SERVICE;**1030,1031**;NOV 01, 1997
+2 ;
+3 ;;VA LR Patch(s): 295
+4 ;
+5 QUIT
+6 ;===============================================================
MICRO ; 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 ;Build the indexes for LAB DATA - MICROBIOLOGY.
+10 NEW AB,ABDN,ACC,ANUMS,DATE,DNUM,DFN,END,ENTRIES,ERR,GLOBAL,IND,ITEM
+11 NEW LRDFN,LRIDT,NE,NERROR,NODE,NUM,ORG,ORGNUM,SPEC,START,SUB
+12 NEW TB,TBDN,TEMP,TENP,TEST,TESTS,TEXT
+13 KILL ANUMS,TESTS
+14 ;Dont leave any old stuff around.
+15 SET GLOBAL=$$GET1^DID(63,"","","GLOBAL NAME")_"""MICRO"")"
+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 - MICROBIOLOGY")
+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 KILL ^TMP("LRPXSXRB",$JOB)
+26 SET NUM=0
+27 FOR
SET NUM=$ORDER(^LAB(62.06,NUM))
IF NUM<1
QUIT
Begin DoDot:1
+28 SET DNUM=+$PIECE($GET(^LAB(62.06,NUM,0)),U,2)
+29 IF DNUM'["2."
QUIT
+30 IF '$DATA(^TMP("LRPXSXRB",$JOB,"AB",DNUM))
SET ^TMP("LRPXSXRB",$JOB,"AB",DNUM)=NUM
End DoDot:1
+31 SET NUM=2
+32 ; dbia 999
FOR
SET NUM=$ORDER(^DD(63.39,NUM))
IF NUM<1
QUIT
Begin DoDot:1
+33 ; dbia 999
SET DNUM=+$PIECE($GET(^DD(63.39,NUM,0)),U,4)
+34 IF DNUM'["2."
QUIT
+35 SET ^TMP("LRPXSXRB",$JOB,"TB",DNUM)=NUM
End DoDot:1
+36 DO AANUMS(.ANUMS)
+37 SET LRDFN=.9
+38 FOR
SET LRDFN=$ORDER(^LR(LRDFN))
IF LRDFN<1
QUIT
Begin DoDot:1
+39 SET TEMP=$GET(^LR(LRDFN,0))
+40 IF $PIECE(TEMP,U,2)'=2
QUIT
+41 SET DFN=+$PIECE(TEMP,U,3)
+42 IF LRDFN'=$$LRDFN^LRPXAPIU(DFN)
QUIT
+43 SET IND=IND+1
+44 IF IND#TENP=0
Begin DoDot:2
+45 SET TEXT="Processing entry "_IND
+46 DO MES^XPDUTL(TEXT)
End DoDot:2
+47 SET LRIDT=0
+48 FOR
SET LRIDT=$ORDER(^LR(LRDFN,"MI",LRIDT))
IF LRIDT<1
QUIT
Begin DoDot:2
+49 SET DATE=+$GET(^LR(LRDFN,"MI",LRIDT,0))
+50 IF 'DATE
QUIT
+51 ; I '$$MIVER^LRPXRM(LRDFN,LRIDT) Q ; IHS/OIT/MKK - LR*5.2*1030 - Commented out for XINDEX
+52 ; IHS/MSC/MKK - LR*5.2*1031
IF '$$MIVER^LRPXRM(LRDFN,LRIDT)
QUIT
+53 SET SPEC=+$PIECE(^LR(LRDFN,"MI",LRIDT,0),U,5)
+54 IF 'SPEC
QUIT
+55 SET ITEM="M;S;"_SPEC
+56 SET NODE=LRDFN_";MI;"_LRIDT_";0"
+57 DO MISET(DFN,ITEM,DATE,NODE)
+58 SET ACC=$PIECE(^LR(LRDFN,"MI",LRIDT,0),U,6)
+59 IF $LENGTH(ACC)
Begin DoDot:3
+60 DO ACC(.TESTS,ACC,DATE,.ANUMS,.ERR)
+61 IF 'ERR
Begin DoDot:4
+62 SET TEST=0
+63 FOR
SET TEST=$ORDER(TESTS(TEST))
IF TEST<1
QUIT
Begin DoDot:5
+64 SET ITEM="M;T;"_TEST
+65 DO MISET(DFN,ITEM,DATE,NODE)
End DoDot:5
End DoDot:4
End DoDot:3
+66 IF $GET(^LR(LRDFN,"MI",LRIDT,1))
Begin DoDot:3
+67 SET ORGNUM=0
+68 FOR
SET ORGNUM=$ORDER(^LR(LRDFN,"MI",LRIDT,3,ORGNUM))
IF ORGNUM<1
QUIT
Begin DoDot:4
+69 SET ORG=+$GET(^LR(LRDFN,"MI",LRIDT,3,ORGNUM,0))
+70 IF 'ORG
QUIT
+71 SET ITEM="M;O;"_ORG
+72 SET NODE=LRDFN_";MI;"_LRIDT_";3;"_ORGNUM_";0"
+73 DO MISET(DFN,ITEM,DATE,NODE)
+74 SET ABDN=1
+75 FOR
SET ABDN=$ORDER(^LR(LRDFN,"MI",LRIDT,3,ORGNUM,ABDN))
IF ABDN<1
QUIT
Begin DoDot:5
+76 SET AB=+$GET(^TMP("LRPXSXRB",$JOB,"AB",ABDN))
+77 IF 'AB
QUIT
+78 SET ITEM="M;A;"_AB
+79 SET NODE=LRDFN_";MI;"_LRIDT_";3;"_ORGNUM_";"_ABDN
+80 DO MISET(DFN,ITEM,DATE,NODE)
End DoDot:5
End DoDot:4
End DoDot:3
+81 FOR SUB=6,9,12,17
Begin DoDot:3
+82 IF '$GET(^LR(LRDFN,"MI",LRIDT,(SUB-1)))
QUIT
+83 SET ORGNUM=0
+84 FOR
SET ORGNUM=$ORDER(^LR(LRDFN,"MI",LRIDT,SUB,ORGNUM))
IF ORGNUM<1
QUIT
Begin DoDot:4
+85 SET ORG=+$GET(^LR(LRDFN,"MI",LRIDT,SUB,ORGNUM,0))
+86 IF 'ORG
QUIT
+87 SET ITEM="M;O;"_ORG
+88 SET NODE=LRDFN_";MI;"_LRIDT_";"_SUB_";"_ORGNUM_";0"
+89 DO MISET(DFN,ITEM,DATE,NODE)
+90 IF SUB'=12
QUIT
+91 SET TBDN=2
+92 FOR
SET TBDN=$ORDER(^LR(LRDFN,"MI",LRIDT,12,ORGNUM,TBDN))
IF TBDN<2
QUIT
Begin DoDot:5
+93 SET TB=+$GET(^TMP("LRPXSXRB",$JOB,"TB",TBDN))
+94 IF '$LENGTH(TB)
QUIT
+95 SET ITEM="M;M;"_TB
+96 SET NODE=LRDFN_";MI;"_LRIDT_";12;"_ORGNUM_";"_TBDN
+97 DO MISET(DFN,ITEM,DATE,NODE)
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+98 KILL ^TMP("LRPXSXRB",$JOB)
+99 SET TEXT=NE_" LAB DATA (MICRO) results indexed."
+100 DO MES^XPDUTL(TEXT)
+101 SET END=$HOROLOG
+102 ; D DETIME^PXRMSXRM(START,END) ; dbia 4113 ; IHS/OIT/MKK - LR*5.2*1030 - Commented out for XINDEX
+103 ; dbia 4113 ; IHS/MSC/MKK - LR*5.2*1031 - Put back in
DO DETIME^PXRMSXRM(START,END)
+104 ;If there were errors send a message.
+105 ; I NERROR>0 D ERRMSG^PXRMSXRM(NERROR,GLOBAL) ; dbia 4113 ; IHS/OIT/MKK - LR*5.2*1030 - Commented out for XINDEX
+106 ; dbia 4113 ; IHS/MSC/MKK - LR*5.2*1031 - Put back in
IF NERROR>0
DO ERRMSG^PXRMSXRM(NERROR,GLOBAL)
+107 ;Send a MailMan message with the results.
+108 ; D COMMSG^PXRMSXRM(GLOBAL,START,END,NE,NERROR) ; dbia 4113 ; IHS/OIT/MKK - LR*5.2*1030 - Commented out for XINDEX
+109 ; S ^PXRMINDX(63,"GLOBAL NAME")=$P(GLOBAL,"""",1) ; dbia 4114 ; IHS/OIT/MKK - LR*5.2*1030 - Commented out for XINDEX
+110 ; S ^PXRMINDX(63,"BUILT BY")=DUZ ; dbia 4114 ; IHS/OIT/MKK - LR*5.2*1030 - Commented out for XINDEX
+111 ; S ^PXRMINDX(63,"DATE BUILT")=$$NOW^XLFDT ; dbia 4114 ; IHS/OIT/MKK - LR*5.2*1030 - Commented out for XINDEX
+112 ; dbia 4113 ; IHS/MSC/MKK - LR*5.2*1031 - Put back in
DO COMMSG^PXRMSXRM(GLOBAL,START,END,NE,NERROR)
+113 ; dbia 4114 ; IHS/MSC/MKK - LR*5.2*1031 - Put back in
SET ^PXRMINDX(63,"GLOBAL NAME")=$PIECE(GLOBAL,"""",1)
+114 ; dbia 4114 ; IHS/MSC/MKK - LR*5.2*1031 - Put back in
SET ^PXRMINDX(63,"BUILT BY")=DUZ
+115 ; dbia 4114 ; IHS/MSC/MKK - LR*5.2*1031 - Put back in
SET ^PXRMINDX(63,"DATE BUILT")=$$NOW^XLFDT
+116 QUIT
+117 ;
MISET(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(MICRO",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(MICRO",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 ;
AANUMS(ANUMS) ; from LRPXSXRA
+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 NEW AA,ABREV
KILL ANUMS
+8 SET AA=0
+9 FOR
SET AA=$ORDER(^LRO(68,AA))
IF AA<1
QUIT
Begin DoDot:1
+10 SET ABREV=$PIECE($GET(^LRO(68,AA,0)),U,11)
+11 IF $LENGTH(ABREV)
SET ANUMS(ABREV)=AA
End DoDot:1
+12 QUIT
+13 ;
ACC(TESTS,ACC,BDN,ANUMS,ERR) ; from LRPXSXRA
+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 ; returns TESTS from micro accession, ACC, BDN required
+7 ; BDN is beginning date number
+8 ; ANUMS is array of accession name numbers (avoids lookup on repeated calls)
+9 NEW DIC,LRAA,LRAAB,LRAD,LRAN,TEST,X,Y
KILL DIC,TESTS
+10 SET ERR=0
+11 IF '$LENGTH($GET(ACC))
SET ERR=1
QUIT
+12 SET LRAAB=$PIECE(ACC," ")
+13 IF LRAAB=""
QUIT
+14 SET BDN=$EXTRACT($GET(BDN))
+15 IF BDN'>1
SET ERR=1
QUIT
+16 SET LRAN=+$PIECE(ACC," ",3)
+17 IF 'LRAN
SET ERR=1
QUIT
+18 SET LRAA=+$GET(ANUMS(LRAAB))
+19 IF 'LRAA
Begin DoDot:1
+20 SET DIC=68
SET DIC(0)="M"
+21 SET X=LRAAB
+22 DO ^DIC
KILL DIC
+23 SET LRAA=+Y
+24 SET ANUMS(LRAAB)=LRAA
End DoDot:1
+25 IF LRAA'>0
SET ERR=1
QUIT
+26 ; yearly acc areas are assumed
SET LRAD=BDN_$PIECE(ACC," ",2)_"0000"
+27 SET TEST=0
+28 FOR
SET TEST=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,TEST))
IF TEST<1
QUIT
Begin DoDot:1
+29 SET TESTS(TEST)=TEST
End DoDot:1
+30 QUIT
+31 ;
