source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LROW1.m@ 810

Last change on this file since 810 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.9 KB
Line 
1LROW1 ;SLC/CJS - TEST & SAMP ;8/11/97
2 ;;5.2;LAB SERVICE;**55,100,121,128**;Sep 27, 1994
3 K LRSAME,DIC,LRTEST,LRSAMP,LRXST,LRCCOM,LRGCOM S LRTSTN=0 S:'$D(LRCOM) LRCOM=0
4L2 K LRNEDC,LROUT K:'$G(LRNN) LRURG ;LRNN=1 when coming from LRFAST
5 S DIC="^LAB(60,",DIC(0)="AEMOQ" S DIC("S")="I $L($P(^(0),U,4)),""BI""[$P(^(0),U,3)" S:LRLWC="LC"!(LRLWC="I") DIC("S")=DIC("S")_",$P(^(0),U,9)"
6 D ^DIC S:X="^^" DIROUT=1 S:Y<1&$D(LRADDTST) LRADDTST=LRADDTST_"^OUT" Q:Y<1 S LRTY=+Y
7NOASK ;from LROR
8 S LRTSTN=LRTSTN+1,LRTEST(LRTSTN)=LRTY,LRY=$S($D(LRURG):+LRURG,1:$P(^LAB(60,LRTY,0),U,18)),H=+$P(^(0),U,16) G L3:LRY
9 I '$D(LROUTINE) K DIC S DIC="^LAB(62.05,",DIC(0)="AEQF",DIC("B")="ROUTINE",DIC("S")="I '$P(^(0),U,3),Y'<"_H S:LRLWC="LC" DIC("S")=DIC("S")_" I $P(^(0),U,2)" F I=0:0 D ^DIC S LRY=+Y Q:LRY>0 W " no '^' allowed"
10 I $D(LROUTINE) S LRY=LROUTINE
11L3 ;
12 S LRY=+LRY,LRTEST(LRTSTN)=LRTEST(LRTSTN)_"^"_$S(LRY'=-1:LRY,1:$P(^LAB(69.9,1,3),U,2))
13 I $G(LRORIFN),$$VER^LR7OU1 S $P(LRTEST(LRTSTN),"^",7)=LRORIFN ;OE/RR 2.5
14 S LRCSN=0,LRSPEC=$S($D(LRSAME):+LRSAME,1:""),LRSAMP=$S($D(LRSAME):+$P(LRSAME,U,2),1:"")
15 K DIC,LRCS,LRCSX,H
16 W !,"For "_$P(^LAB(60,+LRTEST(LRTSTN),0),"^")_" "
17 I LRLWC="LC" S LRCSN=1,LRCS(1)=$P(^LAB(60,+LRTEST(LRTSTN),0),U,9),LRCSX(+LRCS(1))=1 G W18
18 S J=$O(^LAB(60,+LRTEST(LRTSTN),3,0)) G W12:J<1 S LRCSN=1,LRUNQ=+$P(^LAB(60,+LRTEST(LRTSTN),0),U,8),LRCS(1)=+^(3,J,0),LRCSX(+^(0))=1 S X=$P(^LAB(62,LRCS(LRCSN),0),U),X1=$P(^(0),U,3)
19 W:'$D(LRSAME)!LRUNQ X," ",X1
20 G W18:LRUNQ
21 G W18B:$D(LRSAME)
22 I LRCSN=1 W !,"Correct sample" S %=1 D YN^DICN G W18:%=1
23 S J=0 F S J=$O(^LAB(60,+LRTEST(LRTSTN),3,J)) Q:J<1 S:'$D(LRCSX(+^LAB(60,+LRTEST(LRTSTN),3,J,0))) LRCSN=LRCSN+1,LRCS(LRCSN)=+^(0),LRCSX(+^(0))=J
24 G W12:LRCSN<2
25 F I=1:1:LRCSN W !,I," ",$P(^LAB(62,LRCS(I),0),U)," ",$P(^(0),U,3)
26 R !,"Choose one: ",X:DTIME IF X?.N&(X>0)&(X<(LRCSN+1)) S LRCSN=+X W " ",$P(^LAB(62,LRCS(LRCSN),0),U) G W18
27W12 K DUOUT,DTOUT S LRNEDC=1,DIC="^LAB(62,",DIC(0)="AEFMOQ" D ^DIC I $D(DUOUT)!$D(DTOUT) S LRTSTN=LRTSTN-1 G L2
28 G W12:Y<1 S LRCSN=1,LRCS(1)=+Y
29W18 S (LRSPEC,Y)=$P(^LAB(62,+LRCS(LRCSN),0),U,2) I LRUNKNOW=+Y,'$D(LRLABKY) W !,"Unknown is not allowed." G W12
30W18A I 'LRSPEC S DIC="^LAB(61,",DIC(0)="EMOQ",D="E" R !,"Select SITE/SPECIMEN: ",X:DTIME D IX^DIC:X="?" G W18A:X="?" D ^DIC K DIC I $D(DUOUT)!$D(DTOUT)!(X="") K DTOUT,DUOUT S LRTSTN=LRTSTN-1 G L2
31 I LRUNKNOW=+Y,'$D(LRLABKY) W !,"Unknown is not allowed." G W18
32 G W18:Y<1 S LRSPEC=+Y
33MAX ;
34 S LRMAX1=0,LRMAX2=0 I $O(^LAB(60,LRTY,3,"B",+LRCS(LRCSN),0)) S LRMAX2=+$P(^LAB(60,LRTY,3,$O(^LAB(60,LRTY,3,"B",+LRCS(LRCSN),0)),0),U,5) I LRMAX2 D NEW^LRORD2A I $D(LRDAX),%'["Y" S LRTSTN=LRTSTN-1 G L2
35 I 'LRMAX2,$D(TT(LRTY,LRSPEC)),$D(^LAB(60,LRTY,3,"B",+LRCS(LRCSN))) S LRMAX1=+$P(^LAB(60,LRTY,3,$O(^LAB(60,LRTY,3,"B",+LRCS(LRCSN),0)),0),U,7)
36 I 'LRMAX2,LRMAX1,$D(TT(LRTY,LRSPEC)) I TT(LRTY,LRSPEC)'<LRMAX1 D EN1^LRORDD K LRMAX1 I %'["Y" K LRTEST(LRTSTN) S LRTSTN=LRTSTN-1 G L2
37W18B F I=0:0 S I=$O(T(LRTY,I)) Q:I="" Q:LRSPEC=T(LRTY,I)
38 I '$D(LRSAME) S (LRSAMP(LRTSTN),LRSAMP)=+LRCS(LRCSN),LRCSP=+$O(^LAB(60,+LRTEST(LRTSTN),3,"B",+LRSAMP,0))
39 I $D(LRSAME) K LRCS S LRCSN=1,LRSAMP=+$P(LRSAME,U,2),LRSAMP(LRTSTN)=LRSAMP,LRCS(LRCSN)=LRSAMP,LRCSP=+$O(^LAB(60,+LRTEST(LRTSTN),3,"B",+LRSAMP,0))
40 I $D(LRADDTST) N I,GOT D
41 . N LRODT,LRSN S (GOT,LRODT)=0 F S LRODT=$O(^LRO(69,"C",+LRADDTST,LRODT)) Q:LRODT<1 D Q:GOT
42 .. S LRSN=0 F S LRSN=$O(^LRO(69,"C",+LRADDTST,LRODT,LRSN)) Q:LRSN<1 D Q:GOT
43 ... I $P($G(^LRO(69,LRODT,1,LRSN,0)),"^",3)=+LRSAMP,$D(^LRO(69,LRODT,1,LRSN,2,"B",+LRTEST(LRTSTN))) S I=$O(^(+LRTEST(LRTSTN),0)) I I,$D(^LRO(69,LRODT,1,LRSN,2,I,0)),'$P(^(0),"^",11) D
44 .... W !!,$C(7),"<<DUPLICATE TEST NOT ALLOWED>>",!?5,$P(^LAB(60,+LRTEST(LRTSTN),0),"^")_" has already been requested on this order.",!! K LRTEST(LRTSTN) S LRTSTN=LRTSTN-1,GOT=1 Q
45 I $D(LRADDTST),$G(GOT) G L2
46 I '$D(LRLABKY) S DIC="^LAB(60,",DA=+LRTEST(LRTSTN),DR=6 D EN^DIQ S DIC="WARD REMARKS: " S DR=0 F S DR=$O(^LAB(60,DA,3,LRCSP,1,DR)) Q:DR'>0 W !," ",DIC,^(DR,0) S DIC=""
47 G ^LROW1A
Note: See TracBrowser for help on using the repository browser.