BLRALBM ;DAOU/ALA-Build Micro result [ 11/18/2002 1:33 PM ]
;;5.2;LR;**1013,1015**;NOV 18, 2002
;
EN ;
S LRPATLOC=$S($D(LRLLOC):LRLLOC,1:""),LRLOC=LRPATLOC
S LRONETST="",LRONESPC="",LREND=0 D ^LRPARAM
S LRLLT=$G(^LR(LRDFN,"MI",LRIDT,0)),LRACC=$P(LRLLT,U,6)
S LRAD=$E(LRLLT)_$P(LRACC," ",2)_"0000",X=$P(LRACC," "),DIC=68,DIC(0)="M"
Q:'$L(X)
D ^DIC S LRAA=+Y,LRAN=+$P(LRACC," ",3),LRCMNT=$G(^LR(LRDFN,"MI",LRIDT,99)),LRPG=0
I '$D(LRONESPC) S LRONESPC="",DIC="^LAB(61,",DIC("A")="Select SPECIMEN/SOURCE: ANY//",DIC(0)="AEMOQ" D ^DIC S:Y>0 LRONESPC=+Y K DIC("A")
I '$D(LRONETST) S LRONETST="",DIC="^LAB(60,",DIC(0)="AEOQ",DIC("S")="I $P(^(0),U,4)=""MI"")"_$S('$D(LRLABKY):",""BO""[$P(^(0),U,3)",1:""),D="E" D IX^DIC Q:Y<1 I Y>0 S LRONETST=+Y
S LRSPEC=$P(LRLLT,U,5) I LRONESPC'="",LRSPEC'=LRONESPC Q
D RPT
K %,A8,A,AB,B,B1,B2,B3,C,IA,LR1PASS,LR2ORMOR,LRABCNT,LRACNT,LRADM
K LRADX,LRAFS,LRAMT,LRAX,LRBN,LRBRR,LRBUG,LRCOMTAB,LRCS,LRDCOM,LRDOC
K LRDRTM1,LRDRTM2,LREF,LRFLIP,LRFMT,LRGRM,LRHC,LRIFN,LRINT,LRPATLOC
K LRMYC,LRNS,LRNUM,LRORG,LRPAR,LRPC,LRPRE,LRPRINT,LRQU,LRRC,LRRES
K LRSBC1,LRSBC2,LRSET,LRSIC1,LRSIC2,LRSPEC,LRSSD,LRST,LRTA,LRTB,LRTBA
K LRTBC,LRTBS,LRTK,LRTS,LRTSTS,LRTUS,LRUS,LRWRD,N
Q
RPT S:'$D(LRSB) LRSB=0
S LRPRINT=$S($D(^LRO(68,LRAA,1,LRAD,1,LRAN,4)):"",1:1)
S LRHC=$S($E(IOST,1,2)'="C-":1,1:0),LRFLIP=$S(LRHC:11,1:6)
I $D(DUZ("AG")),$L(DUZ("AG")),"ARMYAFN"[DUZ("AG"),LRDPF=2 S LRFDT=9999999-LRIDT D REG^LRAC9 K LRFDT
K DIC D DT^LRX
S LRDPF=$P($G(^LR(LRDFN,0)),U,2),DFN=$P($G(^(0)),U,3) D PT^LRX
S:$G(VAIN(3)) DOB=$P(VAIN(3),U,2) S LRPATLOC=$P(LRLLT,U,8)
S (LRADM,LRADX)="" I +$G(LRDPF)=2,'$G(VAERR) D
. S LRADM=$S($L(VAIN(7)):$P(VAIN(7),U,2),1:"")
. S LRADX=$S($L(VAIN(9)):VAIN(9),1:"")
S LRCS=$P($G(^LAB(62,+$P(LRLLT,U,11),0)),U,1)
S LRTK=$P(LRLLT,U),LRRC=$P(LRLLT,U,10)
S LRST=$S(LRSPEC:$P($G(^LAB(61,LRSPEC,0)),U),1:""),Y=LRTK D D^LRU
S LRTK=Y,Y=LRRC D D^LRU S LRRC=Y
S X=$P(LRLLT,U,7) D DOC^LRX
K ^TMP("LR",$J,"T"),LRTSTS
S LRBRR=0 F S LRBRR=+$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRBRR)) Q:LRBRR<1 D EN1
I 'LRPRINT,LRONETST Q
;
D HDR
D LIN^BLRALBA
;
I $D(^TMP("LR",$J,"T")) D
. S BLRAZ=$E(BLRABLKS,1,5)_"Test(s) ordered:"
. S J="" F S J=$O(^TMP("LR",$J,"T",J)) Q:J="" S X=^(J) D
.. S BLRAZ1=23 D Z1
.. S BLRAZ=BLRAZ_$P(X,U) S Y=$P(X,U,2) D:$L(Y) D^LRU
.. I $L(Y) S BLRAZ1=43 D Z1 S BLRAZ=BLRAZ_" completed: "_Y
.. S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)=BLRAZ,BLRAZ=""
K ^TMP("LR",$J,"T"),LRTSTS
I $D(^LR(LRDFN,"MI",LRIDT,14)) D ANTI^BLRALBM1
I $D(^LR(LRDFN,"MI",LRIDT,1)) D BACT^BLRALBM1,REFS
I $D(^LR(LRDFN,"MI",LRIDT,31)) D STER^BLRALBM2
I $D(^LR(LRDFN,"MI",LRIDT,5)) D PARA^BLRALBM2,REFS
I $D(^LR(LRDFN,"MI",LRIDT,16)) D VIR^BLRALBM2,REFS
I $D(^LR(LRDFN,"MI",LRIDT,11)) D TB^BLRALBM3,REFS
I $D(^LR(LRDFN,"MI",LRIDT,8)) D FUNG^BLRALBM3,REFS
Q
;
EN1 S LRTS=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRBRR,0)),LRTS(1)=$P($G(^(0)),U,5)
Q:'$L($P($G(^LAB(60,LRTS,0)),U,3)) I '$D(LRLABKY),"BO"'[$P($G(^LAB(60,LRTS,0)),U,3) Q
S:LRTS=LRONETST LRPRINT=1 S LRTSTS=$S($D(^LAB(60,LRTS,0)):$P($G(^(0)),U),1:"deleted test"),^TMP("LR",$J,"T",$S($D(^LAB(60,LRTS,.1)):$P($G(^(.1)),U,6),1:"")_","_LRBRR)=LRTSTS_U_LRTS(1)
Q
;
REFS ;
S B=1,LREF=0
F S LREF=$O(LRBUG(LREF)) Q:LREF="" S LRIFN=LRBUG(LREF) D LIST
K LRBUG
Q
LIST Q:'$D(^LAB(61.2,LRIFN,"JR",0))
S LRNUM=0
F S LRNUM=$O(^LAB(61.2,LRIFN,"JR",LRNUM)) Q:LRNUM="" D WR
Q
WR S X1=$G(^LAB(61.2,LRIFN,"JR",LRNUM,0)) Q:$P(X1,U,7)'=1
I B=1 S BLRAZ="Reference(s): " S B=0,BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)=BLRAZ
D LIN^BLRALBM1
S BLRAZ=$J(LREF,2)_". "_$P(X1,U,2)
S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)=BLRAZ
S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)=$P(X1,U)
I $L($P(X1,U,3)) S BLRAZ=$P($G(^LAB(95,$P(X1,U,3),0)),U)_" "_$P(X1,U,4)_":"
S BLRAZ=BLRAZ_$P(X1,U,5)
I $L($P(X1,U,6)) S BLRAZ=BLRAZ_","_$E($P(X1,U,6),1,3)+1700
S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)=BLRAZ
Q
;
Z1 ; Pad with trailing spaces
F BLRAI=1:1:(BLRAZ1-$L(BLRAZ)) S BLRAZ=BLRAZ_" "
Q
;
HDR ;
;S BLRAZ=PNM,BLRAZ1=20 D Z1
;S BLRAZ=BLRAZ_" "_HRCN,BLRAZ1=35 D Z1
;S BLRAZ=BLRAZ_" AGE: "_AGE
;I $L(LRWRD) S BLRAZ1=46 D Z1 S BLRAZ=BLRAZ_"LOC: "_LRWRD
I $L(LRWRD) S LRLOC=LRWRD
;S BLRAZ1=61 D Z1
;S BLRAZ=BLRAZ_" "_LRDT0 S A8=$P($H,",",2),Y=A8\3600_":"_$E((A8\60#60+100),2,3)
;S BLRAZ=BLRAZ_" "_Y
;S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)=BLRAZ
S BLRAZ=$E(BLRABLKS,1,27)_"----MICROBIOLOGY----"
S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)=BLRAZ
;I $D(DUZ("AG")),$L(DUZ("AG")),"ARMYAFN"[DUZ("AG") D ^LRAIPRIV
;I '$D(LRH),LRHC W !?32,$S($D(^XUSEC("LRLAB",DUZ))&'$D(LRWRDVEW):"LAB",1:"CHART")," COPY"
S BLRAZ="Accession: "_LRACC,BLRAZ1=40 D Z1
S BLRAZ=BLRAZ_"Received: "_LRRC
S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)=BLRAZ
S BLRAZ="Collection sample: "_LRCS,BLRAZ1=40 D Z1
S BLRAZ=BLRAZ_"Collection date: "_LRTK
S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)=BLRAZ
I LRCS'=LRST D
. S BLRAZ="Site/Specimen: "_LRST
. S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)=BLRAZ
S BLRAZ="Provider: "_LRDOC
S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)=BLRAZ
I $L(LRCMNT) D
. S BLRAZ="Comment on specimen: "_LRCMNT
. S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)=BLRAZ
Q
BLRALBM ;DAOU/ALA-Build Micro result [ 11/18/2002 1:33 PM ]
+1 ;;5.2;LR;**1013,1015**;NOV 18, 2002
+2 ;
EN ;
+1 SET LRPATLOC=$SELECT($DATA(LRLLOC):LRLLOC,1:"")
SET LRLOC=LRPATLOC
+2 SET LRONETST=""
SET LRONESPC=""
SET LREND=0
DO ^LRPARAM
+3 SET LRLLT=$GET(^LR(LRDFN,"MI",LRIDT,0))
SET LRACC=$PIECE(LRLLT,U,6)
+4 SET LRAD=$EXTRACT(LRLLT)_$PIECE(LRACC," ",2)_"0000"
SET X=$PIECE(LRACC," ")
SET DIC=68
SET DIC(0)="M"
+5 IF '$LENGTH(X)
QUIT
+6 DO ^DIC
SET LRAA=+Y
SET LRAN=+$PIECE(LRACC," ",3)
SET LRCMNT=$GET(^LR(LRDFN,"MI",LRIDT,99))
SET LRPG=0
+7 IF '$DATA(LRONESPC)
SET LRONESPC=""
SET DIC="^LAB(61,"
SET DIC("A")="Select SPECIMEN/SOURCE: ANY//"
SET DIC(0)="AEMOQ"
DO ^DIC
IF Y>0
SET LRONESPC=+Y
KILL DIC("A")
+8 IF '$DATA(LRONETST)
SET LRONETST=""
SET DIC="^LAB(60,"
SET DIC(0)="AEOQ"
SET DIC("S")="I $P(^(0),U,4)=""MI"")"_$SELECT('$DATA(LRLABKY):",""BO""[$P(^(0),U,3)",1:"")
SET D="E"
DO IX^DIC
IF Y<1
QUIT
IF Y>0
SET LRONETST=+Y
+9 SET LRSPEC=$PIECE(LRLLT,U,5)
IF LRONESPC'=""
IF LRSPEC'=LRONESPC
QUIT
+10 DO RPT
+11 KILL %,A8,A,AB,B,B1,B2,B3,C,IA,LR1PASS,LR2ORMOR,LRABCNT,LRACNT,LRADM
+12 KILL LRADX,LRAFS,LRAMT,LRAX,LRBN,LRBRR,LRBUG,LRCOMTAB,LRCS,LRDCOM,LRDOC
+13 KILL LRDRTM1,LRDRTM2,LREF,LRFLIP,LRFMT,LRGRM,LRHC,LRIFN,LRINT,LRPATLOC
+14 KILL LRMYC,LRNS,LRNUM,LRORG,LRPAR,LRPC,LRPRE,LRPRINT,LRQU,LRRC,LRRES
+15 KILL LRSBC1,LRSBC2,LRSET,LRSIC1,LRSIC2,LRSPEC,LRSSD,LRST,LRTA,LRTB,LRTBA
+16 KILL LRTBC,LRTBS,LRTK,LRTS,LRTSTS,LRTUS,LRUS,LRWRD,N
+17 QUIT
RPT IF '$DATA(LRSB)
SET LRSB=0
+1 SET LRPRINT=$SELECT($DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4)):"",1:1)
+2 SET LRHC=$SELECT($EXTRACT(IOST,1,2)'="C-":1,1:0)
SET LRFLIP=$SELECT(LRHC:11,1:6)
+3 IF $DATA(DUZ("AG"))
IF $LENGTH(DUZ("AG"))
IF "ARMYAFN"[DUZ("AG")
IF LRDPF=2
SET LRFDT=9999999-LRIDT
DO REG^LRAC9
KILL LRFDT
+4 KILL DIC
DO DT^LRX
+5 SET LRDPF=$PIECE($GET(^LR(LRDFN,0)),U,2)
SET DFN=$PIECE($GET(^(0)),U,3)
DO PT^LRX
+6 IF $GET(VAIN(3))
SET DOB=$PIECE(VAIN(3),U,2)
SET LRPATLOC=$PIECE(LRLLT,U,8)
+7 SET (LRADM,LRADX)=""
IF +$GET(LRDPF)=2
IF '$GET(VAERR)
Begin DoDot:1
+8 SET LRADM=$SELECT($LENGTH(VAIN(7)):$PIECE(VAIN(7),U,2),1:"")
+9 SET LRADX=$SELECT($LENGTH(VAIN(9)):VAIN(9),1:"")
End DoDot:1
+10 SET LRCS=$PIECE($GET(^LAB(62,+$PIECE(LRLLT,U,11),0)),U,1)
+11 SET LRTK=$PIECE(LRLLT,U)
SET LRRC=$PIECE(LRLLT,U,10)
+12 SET LRST=$SELECT(LRSPEC:$PIECE($GET(^LAB(61,LRSPEC,0)),U),1:"")
SET Y=LRTK
DO D^LRU
+13 SET LRTK=Y
SET Y=LRRC
DO D^LRU
SET LRRC=Y
+14 SET X=$PIECE(LRLLT,U,7)
DO DOC^LRX
+15 KILL ^TMP("LR",$JOB,"T"),LRTSTS
+16 SET LRBRR=0
FOR
SET LRBRR=+$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRBRR))
IF LRBRR<1
QUIT
DO EN1
+17 IF 'LRPRINT
IF LRONETST
QUIT
+18 ;
+19 DO HDR
+20 DO LIN^BLRALBA
+21 ;
+22 IF $DATA(^TMP("LR",$JOB,"T"))
Begin DoDot:1
+23 SET BLRAZ=$EXTRACT(BLRABLKS,1,5)_"Test(s) ordered:"
+24 SET J=""
FOR
SET J=$ORDER(^TMP("LR",$JOB,"T",J))
IF J=""
QUIT
SET X=^(J)
Begin DoDot:2
+25 SET BLRAZ1=23
DO Z1
+26 SET BLRAZ=BLRAZ_$PIECE(X,U)
SET Y=$PIECE(X,U,2)
IF $LENGTH(Y)
DO D^LRU
+27 IF $LENGTH(Y)
SET BLRAZ1=43
DO Z1
SET BLRAZ=BLRAZ_" completed: "_Y
+28 SET BLRADSP=BLRADSP+1
SET ^TMP($JOB,"BLRA",BLRADSP,0)=BLRAZ
SET BLRAZ=""
End DoDot:2
End DoDot:1
+29 KILL ^TMP("LR",$JOB,"T"),LRTSTS
+30 IF $DATA(^LR(LRDFN,"MI",LRIDT,14))
DO ANTI^BLRALBM1
+31 IF $DATA(^LR(LRDFN,"MI",LRIDT,1))
DO BACT^BLRALBM1
DO REFS
+32 IF $DATA(^LR(LRDFN,"MI",LRIDT,31))
DO STER^BLRALBM2
+33 IF $DATA(^LR(LRDFN,"MI",LRIDT,5))
DO PARA^BLRALBM2
DO REFS
+34 IF $DATA(^LR(LRDFN,"MI",LRIDT,16))
DO VIR^BLRALBM2
DO REFS
+35 IF $DATA(^LR(LRDFN,"MI",LRIDT,11))
DO TB^BLRALBM3
DO REFS
+36 IF $DATA(^LR(LRDFN,"MI",LRIDT,8))
DO FUNG^BLRALBM3
DO REFS
+37 QUIT
+38 ;
EN1 SET LRTS=+$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRBRR,0))
SET LRTS(1)=$PIECE($GET(^(0)),U,5)
+1 IF '$LENGTH($PIECE($GET(^LAB(60,LRTS,0)),U,3))
QUIT
IF '$DATA(LRLABKY)
IF "BO"'[$PIECE($GET(^LAB(60,LRTS,0)),U,3)
QUIT
+2 IF LRTS=LRONETST
SET LRPRINT=1
SET LRTSTS=$SELECT($DATA(^LAB(60,LRTS,0)):$PIECE($GET(^(0)),U),1:"deleted test")
SET ^TMP("LR",$JOB,"T",$SELECT($DATA(^LAB(60,LRTS,.1)):$PIECE($GET(^(.1)),U,6),1:"")_","_LRBRR)=LRTSTS_U_LRTS(1)
+3 QUIT
+4 ;
REFS ;
+1 SET B=1
SET LREF=0
+2 FOR
SET LREF=$ORDER(LRBUG(LREF))
IF LREF=""
QUIT
SET LRIFN=LRBUG(LREF)
DO LIST
+3 KILL LRBUG
+4 QUIT
LIST IF '$DATA(^LAB(61.2,LRIFN,"JR",0))
QUIT
+1 SET LRNUM=0
+2 FOR
SET LRNUM=$ORDER(^LAB(61.2,LRIFN,"JR",LRNUM))
IF LRNUM=""
QUIT
DO WR
+3 QUIT
WR SET X1=$GET(^LAB(61.2,LRIFN,"JR",LRNUM,0))
IF $PIECE(X1,U,7)'=1
QUIT
+1 IF B=1
SET BLRAZ="Reference(s): "
SET B=0
SET BLRADSP=BLRADSP+1
SET ^TMP($JOB,"BLRA",BLRADSP,0)=BLRAZ
+2 DO LIN^BLRALBM1
+3 SET BLRAZ=$JUSTIFY(LREF,2)_". "_$PIECE(X1,U,2)
+4 SET BLRADSP=BLRADSP+1
SET ^TMP($JOB,"BLRA",BLRADSP,0)=BLRAZ
+5 SET BLRADSP=BLRADSP+1
SET ^TMP($JOB,"BLRA",BLRADSP,0)=$PIECE(X1,U)
+6 IF $LENGTH($PIECE(X1,U,3))
SET BLRAZ=$PIECE($GET(^LAB(95,$PIECE(X1,U,3),0)),U)_" "_$PIECE(X1,U,4)_":"
+7 SET BLRAZ=BLRAZ_$PIECE(X1,U,5)
+8 IF $LENGTH($PIECE(X1,U,6))
SET BLRAZ=BLRAZ_","_$EXTRACT($PIECE(X1,U,6),1,3)+1700
+9 SET BLRADSP=BLRADSP+1
SET ^TMP($JOB,"BLRA",BLRADSP,0)=BLRAZ
+10 QUIT
+11 ;
Z1 ; Pad with trailing spaces
+1 FOR BLRAI=1:1:(BLRAZ1-$LENGTH(BLRAZ))
SET BLRAZ=BLRAZ_" "
+2 QUIT
+3 ;
HDR ;
+1 ;S BLRAZ=PNM,BLRAZ1=20 D Z1
+2 ;S BLRAZ=BLRAZ_" "_HRCN,BLRAZ1=35 D Z1
+3 ;S BLRAZ=BLRAZ_" AGE: "_AGE
+4 ;I $L(LRWRD) S BLRAZ1=46 D Z1 S BLRAZ=BLRAZ_"LOC: "_LRWRD
+5 IF $LENGTH(LRWRD)
SET LRLOC=LRWRD
+6 ;S BLRAZ1=61 D Z1
+7 ;S BLRAZ=BLRAZ_" "_LRDT0 S A8=$P($H,",",2),Y=A8\3600_":"_$E((A8\60#60+100),2,3)
+8 ;S BLRAZ=BLRAZ_" "_Y
+9 ;S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)=BLRAZ
+10 SET BLRAZ=$EXTRACT(BLRABLKS,1,27)_"----MICROBIOLOGY----"
+11 SET BLRADSP=BLRADSP+1
SET ^TMP($JOB,"BLRA",BLRADSP,0)=BLRAZ
+12 ;I $D(DUZ("AG")),$L(DUZ("AG")),"ARMYAFN"[DUZ("AG") D ^LRAIPRIV
+13 ;I '$D(LRH),LRHC W !?32,$S($D(^XUSEC("LRLAB",DUZ))&'$D(LRWRDVEW):"LAB",1:"CHART")," COPY"
+14 SET BLRAZ="Accession: "_LRACC
SET BLRAZ1=40
DO Z1
+15 SET BLRAZ=BLRAZ_"Received: "_LRRC
+16 SET BLRADSP=BLRADSP+1
SET ^TMP($JOB,"BLRA",BLRADSP,0)=BLRAZ
+17 SET BLRAZ="Collection sample: "_LRCS
SET BLRAZ1=40
DO Z1
+18 SET BLRAZ=BLRAZ_"Collection date: "_LRTK
+19 SET BLRADSP=BLRADSP+1
SET ^TMP($JOB,"BLRA",BLRADSP,0)=BLRAZ
+20 IF LRCS'=LRST
Begin DoDot:1
+21 SET BLRAZ="Site/Specimen: "_LRST
+22 SET BLRADSP=BLRADSP+1
SET ^TMP($JOB,"BLRA",BLRADSP,0)=BLRAZ
End DoDot:1
+23 SET BLRAZ="Provider: "_LRDOC
+24 SET BLRADSP=BLRADSP+1
SET ^TMP($JOB,"BLRA",BLRADSP,0)=BLRAZ
+25 IF $LENGTH(LRCMNT)
Begin DoDot:1
+26 SET BLRAZ="Comment on specimen: "_LRCMNT
+27 SET BLRADSP=BLRADSP+1
SET ^TMP($JOB,"BLRA",BLRADSP,0)=BLRAZ
End DoDot:1
+28 QUIT
