source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRORD2.m@ 1006

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

initial load of WorldVistAEHR

File size: 3.9 KB
Line 
1LRORD2 ;SLC/CJS - MORE OF LAZY ACCESSION LOGGING ;8/11/97
2 ;;5.2;LAB SERVICE;**121,153**;Sep 27, 1994
3MORE ;get more tests, from LRORD1
4LRM F LRSSX=LRM:1 D Q15,^DIC Q:Y<1 S LRWPC=LRWPC+1,LRTSTS=+Y,LRTX(LRTSTS)="",LRURGG=$P(Y(0),U,18) D ENQ K DIC("S") D GS^LRORD3 I LRSAMP>0&(LRSPEC>0) D Q20 S:'LREND LRM=LRM+1 I LREND K LRSAME Q
5 K LRSAME Q
6ENQ Q:$D(LRLABKY) S DIC="^LAB(60,",DA=LRTSTS,DR=6 D EN^DIQ Q
7Q15 ;from LRORD
8 S DIC("S")="I $P(^(0),U,4)'="""""_$S('$D(LRLABKY):",""NO""'[$P(^(0),U,3)",'$P(LRLABKY,U,3):",""N""'[$P(^(0),U,3)",1:"") S:LRORDR="LC"!(LRORDR="I") DIC("S")=DIC("S")_",$P(^(0),U,9)"
9 S:$G(LRORDRR)="R" DIC("S")=DIC("S")_",$G(^LAB(60,Y,64))"
10 S DIC="^LAB(60,",DIC(0)="AEMOQZ"
11 Q
12Q20 ;
13 S LREND=0,Z=0 F S Z=$O(LROT(LRSAMP,LRSPEC,Z)) Q:Z<1 I +LROT(LRSAMP,LRSPEC,Z)=LRTSTS W !!?20," ~ ",$P(^LAB(60,LRTSTS,0),U)," ",$S($D(^LAB(62,LRSAMP,0)):$P(^(0),U),1:"")," ",$S($D(^LAB(61,LRSPEC,0)):$P(^(0),U),1:"")," ~" D DUP^LRORD2 H 2
14 Q:LREND
15 S LROT(LRSAMP,LRSPEC,LRSSX)=LRTSTS,LREXP=$S($P($G(^LAB(60,LRTSTS,3,+$O(^LAB(60,LRTSTS,3,"B",+LRSAMP,0)),0)),U,6):$P(^(0),U,6),$P(^LAB(60,LRTSTS,0),U,19):$P(^(0),U,19),1:0)
16 I '$D(LRLABKY) S DIC="WARD REMARKS: " S DR=0 F S DR=$O(^LAB(60,LRTSTS,3,+LRSAMP,1,DR)) Q:DR'>0 W !," ",DIC,^(DR,0) S DIC=""
17 S:LREXP LROT(LRSAMP,LRSPEC,LRSSX,2)=LREXP S DIC("B")=LROUTINE D URG
18 Q
19% R %:DTIME Q:%=""!(%["N")!(%["Y") W !,"Answer 'Y' or 'N': " G %
20 W !,"For ",$P(^TMP("LRSTIK",$J,LRSSX),U,2)
21URG ;from LRMIBL, LRORD1, LRWU1
22 S H=+$P(^LAB(60,+LRTSTS,0),U,16),H(0)=$P(^(0),U,18) I $D(LRURGG),LRURGG'<H S X=LRURGG K LRURGG G URG1
23 S:'$D(LROUTINE) LROUTINE=+$P($G(^LAB(69.9,1,3)),U,2)
24 K DIC S DIC("A")="Select Urgency Status: ",DIC("S")="I '$P(^(0),U,3)",DIC="^LAB(62.05,",DIC(0)="AEQ" S DIC("B")=$S(LRORDR="WC":H(0),1:LROUTINE)
25 S DIC("S")="I '$P(^(0),U,3),Y'<"_H S:LRORDR="LC" DIC("S")=DIC("S")_" I $P(^(0),U,2)" D ^DIC S:Y>0 X=+Y S:Y<1 X=9
26URG1 K DIC,H S LROT(LRSAMP,LRSPEC,LRSSX,1)=X Q
27RCOM ;from LRORDST, LROW1
28 S LRCCOM="" S:'$D(LREXP) LREXP=0 S:'$D(LRTSTNM) LRTSTNM="" ;ASK REQUIRED COMENT
29 I LREXP,$L(^LAB(62.07,LREXP,.1)) X ^(.1) Q:$G(LRKIL) W:$E(LRCCOM)="?"&$D(^LAB(62.07,LREXP,.2)) ^(.2) G RCOM:$E(LRCCOM)="?"
30 I 'LREXP R !,"Enter Order Comment: ",LRCCOM:DTIME
31RC1 G ZQ:LRCCOM="?"!(LRCCOM="??"),Z3:LRCCOM=""!(LRCCOM="^") I LRCCOM["^"!(LRCCOM[";") W !,"No up-arrows or semicolons allowed." G ZQ
32Z0 G ZQ:$L(LRCCOM)>67!($L(LRCCOM)<1)!(LRCCOM'?.ANP) S B3="~",LRPCE=$S($E(LRCCOM,1)="~":$E(LRCCOM,1),1:""),LRCCOM=$S($L(LRPCE):$E(LRCCOM,2,999),1:LRCCOM) D Z1 W " (",$E(B3,1,$L(B3)-1),")" S LRCCOM=B3 K A4,B3,B6
33Z3 Q:$D(LRQ)
34 S:LRCCOM["^" LRCCOM="" I $L(LRCCOM) S %=1 W !," OK" D YN^DICN I %'=1 S:%=-1 LRCCOM="" G RCOM:%=2 I %=0 W !,"Unless special comments are required, this comment will be associated with",!,"all tests requested for this entry." G Z3
35 I $D(LRTEST(+$G(LRTSTN))) D TCOM(+LRTEST(LRTSTN),LRCCOM)
36RCS ;from LREXECU, LRORDST, LROW2
37 Q
38Z1 F V=1:1 Q:$P(LRCCOM," ",V,99)="" S B6=$P(LRCCOM," ",V),Y="" D:B6]"" Z2 S A4=$L(B3)+$L(B6) S:A4'>68 B3=B3_B6_" " I A4>68 W " too long",! Q
39 S LRCCOM=$S('$L(LRPCE):LRCCOM,1:LRPCE_LRCCOM) K LRPCE Q
40 Q
41Z2 S Y=0 F S Y=$O(^LAB(62.5,"B",B6,Y)) Q:Y="" I "KA"[$P(^LAB(62.5,Y,0),U,4) S B6=$P(^LAB(62.5,Y,0),"^",2) Q:'$D(^(9)) S Y=$P(X," ",I-1),Y=$E(Y,$L(Y)) S:Y>1 B6=^(9) Q
42 Q
43ZQ S X=$S(LRCCOM="??":"??",1:"?"),(DIE,DIC)="^LAB(62.5,",DIC(0)="Q",DIC("S")="I ""KA""[$P(^(0),U,4)",D="B",DZ=X K DO D DQ^DICQ K DIC S DIC=DIE D DO^DIC1
44 G RCOM
45GCOM ;from LRORD1, LRPHITEM, LRTSTJAN, LRWU1
46 S LREXP=0 D RCOM S LRGCOM=LRCCOM Q
47DUP ;from LRORDD
48 I LRTSTS=+LROT(LRSAMP,LRSPEC,Z) W !,"Since this test, collection sample, and site/specimen has already",!,"been requested on this order, it will NOT be duplicated.",$C(7),!,"If you really need a duplicate, place a separate order." S LREND=1
49 Q
50TCOM(TEST,COM) ;Get comments by test
51 N X
52 Q:'$G(TEST) Q:'$L($GET(COM))
53 S X=1+$S($D(LRTCOM(TEST)):LRTCOM(TEST),1:0),LRTCOM(TEST)=X,LRTCOM(TEST,X)="~For Test: "_$P(^LAB(60,TEST,0),"^")
54 S X=X+1,LRTCOM(TEST)=X,LRTCOM(TEST,X)=COM
55 Q
Note: See TracBrowser for help on using the repository browser.