source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LROR6A.m@ 767

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

initial load of WorldVistAEHR

File size: 4.5 KB
Line 
1LROR6A ;SLC/DCM - EDIT UNRELEASED LAB ORDERS FOR OE/RR ;9/11/89 16:55 ;
2 ;;5.2;LAB SERVICE;**24,100,128,186**;Sep 27, 1994
3EDITUR ;FROM LROR6
4 S X=ORPK,LRTST=+X,LROOST=$P(X,"^",2),LROSAMP=$P(X,"^",3),LROSPEC=$P(X,"^",4),LROXZ=$P(X,"^",5),LROURG=$P(X,"^",6),LRORD=$P(X,"^",7),LROCNT=$P(X,"^",8)
5 S LREND=0,LRASK=0,LROST="",LRSAMP="",LRSPEC="",LRURG="",LRTSTNM=$P(^LAB(60,LRTST,0),U,1)
6 D TYPE S:LREND LRZX(1)=LROXZ,LREND=0
7 D INIT^LRXO00
8 S LRPREV=$S($D(LROOST):LROOST,1:"") I LRPREV S Y=LRPREV X ^DD("DD") S LRPREV=Y
9 I LRZX(1)["I" D ^LRORDIM S LROST=$S($D(LRCDT):LRCDT,1:LROOST) S:'$D(LRCDT) LRZX(1)=LROXZ K LRCDT,LRPREV I LRZX(1)'="I" D
10 .W !!,"Invalid time selected this will be returned to ",$S(LRZX(1)["L":"Lab Collect",LRZX(1)["W":"Ward Collect",1:"Send Patient") H 2
11 I LRZX(1)'="I" D EN^LRXO5 D:LREND S:LREND LROST=LROOST,LREND=0 K LRPREV
12 .Q:LRZX(1)'="LC"!(LROXZ="LC")
13 .S LRZX(1)=LROXZ
14 .W !!,"Invalid time selected this will be returned to ",$S(LRZX(1)["W":"Ward Collect",1:"Send Patient") H 2
15 D SAMP K DIC,LRCS,LRUNQ,N1,LRCSN
16 D URG S:LREND LRURG=LROURG,LREND=0
17 I $D(^XUTL("OR",$J,"COM",LROOST,LROXZ,LRSAMP,LRSPEC,LROCNT)),$O(^(LROCNT,0)) D RCOM S LRFLG=1
18 I '$D(LRFLG) S LRSX=LROCNT D RCOM^LRXO2
19 K LRFLG D SET^LROR6B
20 D RETURN^ORX
21 K LROCNT,LROXZ,LROOST,LROURG,LROSAMP,LROSPEC,LRCNT,LRSPEC,LRSAMP,LRSX,LRZX,LREK,LRURG,LROST,LRTST,LRTSTNM,LRCS,LRCSN,LRPRAM,LROUTINE Q
22TYPE W !!," (S)END patient to lab",!," (W)ARD collect & deliver",!," (L)AB blood team" I $P($G(^LAB(69.9,1,7,DUZ(2),0)),U,6) W !," (I)MMEDIATE LAB COLLECT"
23 W !,"Select: "_$S(LROXZ["LC":"LAB",LROXZ["WC":"WARD",LROXZ["I":"IMMEDIATE",1:"SEND")_"//" R X:DTIME I X["^"!(X="")!('$T) S LREND=1 Q
24 S LRCTYPE="SsWwLl" I $P($G(^LAB(69.9,1,7,DUZ(2),0)),U,6) S LRCTYPE=LRCTYPE_"Ii"
25 I LRCTYPE'[X W !,"Enter 'S' for SEND TO LAB",!?6,"'W' for WARD COLLECT",!?6,"'L' for LAB BLOOD TEAM." W:LRCTYPE["I" !?6,"'I' for Immediate Collect",!?6,"'^' to Exit." G TYPE
26 S LRZX(1)=$S(X["W":"WC",X["w":"WC",X["S":"SP",X["s":"SP",X["I":"I",X["i":"I",1:"LC")
27 I LRZX(1)="LC"!(LRZX(1)="I"),'$P(^LAB(60,LRTST,0),"^",9) W !!,$C(7),"**"_$P(LRTSTNM,"^")_" cannot be ordered for ROUTINE LAB COLLECT or IMMEDIATE COLLECT.**" G TYPE
28 K LRCTYPE Q
29URG ;Edit Urgency
30 S H=+$P(^LAB(60,LRTST,0),"^",16),H(0)=$P(^(0),"^",18)
31 S DIC="^LAB(62.05,",DIC(0)="AEQZ" S DIC("A")="URGENCY: " S:'$D(DIC("B")) DIC("B")=$S($D(LROURG):LROURG,1:$P(^LAB(69.9,1,3),"^",2))
32 S DIC("S")="I '$P(^(0),""^"",3),Y'<"_H S:LRZX(1)="LC" DIC("S")=DIC("S")_" I $P(^(0),""^"",2)" W ! D ^DIC I Y<1 S LREND=1 Q
33 S X=+Y K DIC,H S LRURG=X
34 Q
35SAMP ;Edit Collection sample and specimen
36 S LRUNQ=$P(^LAB(60,LRTST,0),"^",8),(J,N1)=$O(^(3,0)),LRCSN=1
37 I "ILC"[LRZX(1) S LRSAMP=$P(^LAB(60,LRTST,0),"^",9) W !,"Lab will collect ",$P(^LAB(62,LRSAMP,0),"^")," ",$P(^(0),"^",3) G SPEC
38 I N1 S LRCS(1)=+^LAB(60,LRTST,3,N1,0)
39 I N1&(LRUNQ) S X=$P(^LAB(62,LRCS(1),0),"^") W !,"The Sample Is "_X_" "_$P(^(0),"^",3) S LRSAMP=LROSAMP G SPEC
40 I N1 F S J=$O(^LAB(60,LRTST,3,J)) Q:J<1 S LRCSN=LRCSN+1,LRCS(LRCSN)=+^(J,0)
41 I LRCSN>1 G SAMP2
42SAMP1 I LRCSN<2 S DIC="^LAB(62,",DIC(0)="EMOQ",D="B" W !,"COLLECTION SAMPLE: "_$P(^LAB(62,LROSAMP,0),"^")_"//" R X:DTIME D IX^DIC:X["?" G SAMP1:X["?" I X["^"!(X="")!('$T) S LRSAMP=LROSAMP G SPEC
43 I LRCSN<2 D ^DIC K DIC G SAMP1:'($D(DUOUT)!$D(DTOUT))&(Y<0) I $D(DTOUT)!$D(DUOUT) S:X="^^" DIROUT=1 S LRSAMP=LROSAMP G SAMP1
44 S LRSAMP=+Y G SPEC
45SAMP2 I LRCSN>1 W !,"COLLECTION SAMPLE:" F I=1:1:LRCSN W !,I," ",$P(^LAB(62,LRCS(I),0),"^")," ",$P(^(0),"^",3)
46 W !,"Choose one: "_$P(^LAB(62,LROSAMP,0),"^")_"//" R X:DTIME G SAMP2:X["?" I X["^"!(X="")!('$T) S LRSAMP=LROSAMP G SPEC
47 I '$D(LRCS(X)) W $C(7),!,"Type number 1-",LRCSN,! H 1 G SAMP2
48 S LRSAMP=$P(LRCS(X),"^") W " "_$P(^LAB(62,LRSAMP,0),"^")_$P(^(0),"^",3) G SPEC
49 Q
50SPEC ;
51 I $P(^LAB(62,LRSAMP,0),"^",2)'="" S LRSPEC=+$P(^(0),"^",2) Q
52SPEC1 S DIC="^LAB(61,",DIC(0)="EMOQ",D="E" W !!,"SITE SPECIMEN: "_$P(^LAB(61,LROSPEC,0),"^")_"//" R X:DTIME D IX^DIC:X["?" G SPEC1:X["?" I X["^"!(X="")!('$T) S LRSPEC=LROSPEC Q
53 D ^DIC
54 K DIC G SPEC1:'($D(DUOUT)!$D(DTOUT))&(Y<0) I $D(DTOUT)!$D(DUOUT) S:X="^^" DIROUT=1 S LRSPEC=LROSPEC Q
55 S LRSPEC=+Y
56 Q
57RCOM ;Edit comment
58 W !!,"This is the existing comment "
59 S I=0 F S I=$O(^XUTL("OR",$J,"COM",LROOST,LROXZ,LRSAMP,LRSPEC,LROCNT,I)) Q:I<1 S TEXT=^(I) W TEXT,!
60 K TEXT W !,"Do you want to change the comment for this order? " S %=2 D YN^DICN G:%=0 RCOM
61 I %'=1,((LROST'=LROOST)!(LRZX(1)'=LROXZ)) M ^XUTL("OR",$J,"COM",LROST,LRZX(1),LRSAMP,LRSPEC,LROCNT)=^XUTL("OR",$J,"COM",LROOST,LROXZ,LRSAMP,LRSPEC,LROCNT) Q
62 S LRSX=LROCNT K ^XUTL("OR",$J,"COM",LROOST,LROXZ,LRSAMP,LRSPEC,LRSX) D RCOM^LRXO2
63 Q
Note: See TracBrowser for help on using the repository browser.