Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BLRALBM

BLRALBM.m

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