LROR6A ; IHS/DIR/AAB - EDIT UNRELEASED LAB ORDERS FOR OE/RR 9/11/89 16:55 ; [ 07/22/2002 1:30 PM ]
;;5.2T9;LR;**1002,1003,1013,1018**;Nov 17, 2004
;;5.2;LAB SERVICE;**24,100,128,186**;Sep 27, 1994
EDITUR ;FROM LROR6
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)
S LREND=0,LRASK=0,LROST="",LRSAMP="",LRSPEC="",LRURG="",LRTSTNM=$P(^LAB(60,LRTST,0),U,1)
D TYPE S:LREND LRZX(1)=LROXZ,LREND=0
D INIT^LRXO00
S LRPREV=$S($D(LROOST):LROOST,1:"") I LRPREV S Y=LRPREV X ^DD("DD") S LRPREV=Y
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
.;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
.W !!,"Invalid time selected this will be returned to ",$S(LRZX(1)["L":"Lab Collect",LRZX(1)["W":"Ward/Clinic Collect",1:"Send Patient") H 2 ;IHS/DIR TUC/AAB 5/4/98
I LRZX(1)'="I" D EN^LRXO5 D:LREND S:LREND LROST=LROOST,LREND=0 K LRPREV
.Q:LRZX(1)'="LC"!(LROXZ="LC")
.S LRZX(1)=LROXZ
.;W !!,"Invalid time selected this will be returned to ",$S(LRZX(1)["W":"Ward Collect",1:"Send Patient") H 2
.W !!,"Invalid time selected this will be returned to ",$S(LRZX(1)["W":"Ward/Clinic Collect",1:"Send Patient") H 2 ;IHS/DIR TUC/AAB 5/4/98
D SAMP K DIC,LRCS,LRUNQ,N1,LRCSN
D URG S:LREND LRURG=LROURG,LREND=0
I $D(^XUTL("OR",$J,"COM",LROOST,LROXZ,LRSAMP,LRSPEC,LROCNT)),$O(^(LROCNT,0)) D RCOM S LRFLG=1
I '$D(LRFLG) S LRSX=LROCNT D RCOM^LRXO2
K LRFLG D SET^LROR6B
;BEGIN IHS MODIFICATIONS LR*5.2*1018
;RESTORE CALLS TO ORX
D RETURN^ORX ;IHS/DIR TUC/AAB 06/15/98
K LROCNT,LROXZ,LROOST,LROURG,LROSAMP,LROSPEC,LRCNT,LRSPEC,LRSAMP,LRSX,LRZX,LREK,LRURG,LROST,LRTST,LRTSTNM,LRCS,LRCSN,LRPRAM,LROUTINE Q
TYPE ;
;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"
;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
W !!," (S)END patient to lab",!," (W)ARD/CLINIC collect & deliver",!," (L)AB blood team" I $P($G(^LAB(69.9,1,7,DUZ(2),0)),U,6) W !," (I)MMEDIATE LAB COLLECT" ;IHS/DIR TUC/AAB 5/4/98
W !,"Select: "_$S(LROXZ["LC":"LAB",LROXZ["WC":"WARD/CLINIC",LROXZ["I":"IMMEDIATE",1:"SEND")_"//" R X:DTIME I X["^"!(X="")!('$T) S LREND=1 Q ;IHS/DIR TUC/AAB 5/4/98
S LRCTYPE="SsWwLl" I $P($G(^LAB(69.9,1,7,DUZ(2),0)),U,6) S LRCTYPE=LRCTYPE_"Ii"
;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
I LRCTYPE'[X W !,"Enter 'S' for SEND TO LAB",!?6,"'W' for WARD/CLINIC COLLECT",!?6,"'L' for LAB BLOOD TEAM." W:LRCTYPE["I" !?6,"'I' for Immediate Collect",!?6,"'^' to Exit." G TYPE ;IHS/DIR TUC/AAB 5/4/98
S LRZX(1)=$S(X["W":"WC",X["w":"WC",X["S":"SP",X["s":"SP",X["I":"I",X["i":"I",1:"LC")
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
K LRCTYPE Q
URG ;Edit Urgency
S H=+$P(^LAB(60,LRTST,0),"^",16),H(0)=$P(^(0),"^",18)
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))
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
S X=+Y K DIC,H S LRURG=X
Q
SAMP ;Edit Collection sample and specimen
S LRUNQ=$P(^LAB(60,LRTST,0),"^",8),(J,N1)=$O(^(3,0)),LRCSN=1
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
I N1 S LRCS(1)=+^LAB(60,LRTST,3,N1,0)
I N1&(LRUNQ) S X=$P(^LAB(62,LRCS(1),0),"^") W !,"The Sample Is "_X_" "_$P(^(0),"^",3) S LRSAMP=LROSAMP G SPEC
I N1 F S J=$O(^LAB(60,LRTST,3,J)) Q:J<1 S LRCSN=LRCSN+1,LRCS(LRCSN)=+^(J,0)
I LRCSN>1 G SAMP2
SAMP1 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
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
S LRSAMP=+Y G SPEC
SAMP2 I LRCSN>1 W !,"COLLECTION SAMPLE:" F I=1:1:LRCSN W !,I," ",$P(^LAB(62,LRCS(I),0),"^")," ",$P(^(0),"^",3)
W !,"Choose one: "_$P(^LAB(62,LROSAMP,0),"^")_"//" R X:DTIME G SAMP2:X["?" I X["^"!(X="")!('$T) S LRSAMP=LROSAMP G SPEC
I '$D(LRCS(X)) W $C(7),!,"Type number 1-",LRCSN,! H 1 G SAMP2
S LRSAMP=$P(LRCS(X),"^") W " "_$P(^LAB(62,LRSAMP,0),"^")_$P(^(0),"^",3) G SPEC
Q
SPEC ;
I $P(^LAB(62,LRSAMP,0),"^",2)'="" S LRSPEC=+$P(^(0),"^",2) Q
SPEC1 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
D ^DIC
K DIC G SPEC1:'($D(DUOUT)!$D(DTOUT))&(Y<0) I $D(DTOUT)!$D(DUOUT) S:X="^^" DIROUT=1 S LRSPEC=LROSPEC Q
S LRSPEC=+Y
Q
RCOM ;Edit comment
W !!,"This is the existing comment "
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,!
K TEXT W !,"Do you want to change the comment for this order? " S %=2 D YN^DICN G:%=0 RCOM
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
S LRSX=LROCNT K ^XUTL("OR",$J,"COM",LROOST,LROXZ,LRSAMP,LRSPEC,LRSX) D RCOM^LRXO2
Q
LROR6A ; IHS/DIR/AAB - EDIT UNRELEASED LAB ORDERS FOR OE/RR 9/11/89 16:55 ; [ 07/22/2002 1:30 PM ]
+1 ;;5.2T9;LR;**1002,1003,1013,1018**;Nov 17, 2004
+2 ;;5.2;LAB SERVICE;**24,100,128,186**;Sep 27, 1994
EDITUR ;FROM LROR6
+1 SET X=ORPK
SET LRTST=+X
SET LROOST=$PIECE(X,"^",2)
SET LROSAMP=$PIECE(X,"^",3)
SET LROSPEC=$PIECE(X,"^",4)
SET LROXZ=$PIECE(X,"^",5)
SET LROURG=$PIECE(X,"^",6)
SET LRORD=$PIECE(X,"^",7)
SET LROCNT=$PIECE(X,"^",8)
+2 SET LREND=0
SET LRASK=0
SET LROST=""
SET LRSAMP=""
SET LRSPEC=""
SET LRURG=""
SET LRTSTNM=$PIECE(^LAB(60,LRTST,0),U,1)
+3 DO TYPE
IF LREND
SET LRZX(1)=LROXZ
SET LREND=0
+4 DO INIT^LRXO00
+5 SET LRPREV=$SELECT($DATA(LROOST):LROOST,1:"")
IF LRPREV
SET Y=LRPREV
XECUTE ^DD("DD")
SET LRPREV=Y
+6 IF LRZX(1)["I"
DO ^LRORDIM
SET LROST=$SELECT($DATA(LRCDT):LRCDT,1:LROOST)
IF '$DATA(LRCDT)
SET LRZX(1)=LROXZ
KILL LRCDT,LRPREV
IF LRZX(1)'="I"
Begin DoDot:1
+7 ;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
+8 ;IHS/DIR TUC/AAB 5/4/98
WRITE !!,"Invalid time selected this will be returned to ",$SELECT(LRZX(1)["L":"Lab Collect",LRZX(1)["W":"Ward/Clinic Collect",1:"Send Patient")
HANG 2
End DoDot:1
+9 IF LRZX(1)'="I"
DO EN^LRXO5
IF LREND
Begin DoDot:1
+10 IF LRZX(1)'="LC"!(LROXZ="LC")
QUIT
+11 SET LRZX(1)=LROXZ
+12 ;W !!,"Invalid time selected this will be returned to ",$S(LRZX(1)["W":"Ward Collect",1:"Send Patient") H 2
+13 ;IHS/DIR TUC/AAB 5/4/98
WRITE !!,"Invalid time selected this will be returned to ",$SELECT(LRZX(1)["W":"Ward/Clinic Collect",1:"Send Patient")
HANG 2
End DoDot:1
IF LREND
SET LROST=LROOST
SET LREND=0
KILL LRPREV
+14 DO SAMP
KILL DIC,LRCS,LRUNQ,N1,LRCSN
+15 DO URG
IF LREND
SET LRURG=LROURG
SET LREND=0
+16 IF $DATA(^XUTL("OR",$JOB,"COM",LROOST,LROXZ,LRSAMP,LRSPEC,LROCNT))
IF $ORDER(^(LROCNT,0))
DO RCOM
SET LRFLG=1
+17 IF '$DATA(LRFLG)
SET LRSX=LROCNT
DO RCOM^LRXO2
+18 KILL LRFLG
DO SET^LROR6B
+19 ;BEGIN IHS MODIFICATIONS LR*5.2*1018
+20 ;RESTORE CALLS TO ORX
+21 ;IHS/DIR TUC/AAB 06/15/98
DO RETURN^ORX
+22 KILL LROCNT,LROXZ,LROOST,LROURG,LROSAMP,LROSPEC,LRCNT,LRSPEC,LRSAMP,LRSX,LRZX,LREK,LRURG,LROST,LRTST,LRTSTNM,LRCS,LRCSN,LRPRAM,LROUTINE
QUIT
TYPE ;
+1 ;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"
+2 ;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
+3 ;IHS/DIR TUC/AAB 5/4/98
WRITE !!," (S)END patient to lab",!," (W)ARD/CLINIC collect & deliver",!," (L)AB blood team"
IF $PIECE($GET(^LAB(69.9,1,7,DUZ(2),0)),U,6)
WRITE !," (I)MMEDIATE LAB COLLECT"
+4 ;IHS/DIR TUC/AAB 5/4/98
WRITE !,"Select: "_$SELECT(LROXZ["LC":"LAB",LROXZ["WC":"WARD/CLINIC",LROXZ["I":"IMMEDIATE",1:"SEND")_"//"
READ X:DTIME
IF X["^"!(X="")!('$TEST)
SET LREND=1
QUIT
+5 SET LRCTYPE="SsWwLl"
IF $PIECE($GET(^LAB(69.9,1,7,DUZ(2),0)),U,6)
SET LRCTYPE=LRCTYPE_"Ii"
+6 ;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
+7 ;IHS/DIR TUC/AAB 5/4/98
IF LRCTYPE'[X
WRITE !,"Enter 'S' for SEND TO LAB",!?6,"'W' for WARD/CLINIC COLLECT",!?6,"'L' for LAB BLOOD TEAM."
IF LRCTYPE["I"
WRITE !?6,"'I' for Immediate Collect",!?6,"'^' to Exit."
GOTO TYPE
+8 SET LRZX(1)=$SELECT(X["W":"WC",X["w":"WC",X["S":"SP",X["s":"SP",X["I":"I",X["i":"I",1:"LC")
+9 IF LRZX(1)="LC"!(LRZX(1)="I")
IF '$PIECE(^LAB(60,LRTST,0),"^",9)
WRITE !!,$CHAR(7),"**"_$PIECE(LRTSTNM,"^")_" cannot be ordered for ROUTINE LAB COLLECT or IMMEDIATE COLLECT.**"
GOTO TYPE
+10 KILL LRCTYPE
QUIT
URG ;Edit Urgency
+1 SET H=+$PIECE(^LAB(60,LRTST,0),"^",16)
SET H(0)=$PIECE(^(0),"^",18)
+2 SET DIC="^LAB(62.05,"
SET DIC(0)="AEQZ"
SET DIC("A")="URGENCY: "
IF '$DATA(DIC("B"))
SET DIC("B")=$SELECT($DATA(LROURG):LROURG,1:$PIECE(^LAB(69.9,1,3),"^",2))
+3 SET DIC("S")="I '$P(^(0),""^"",3),Y'<"_H
IF LRZX(1)="LC"
SET DIC("S")=DIC("S")_" I $P(^(0),""^"",2)"
WRITE !
DO ^DIC
IF Y<1
SET LREND=1
QUIT
+4 SET X=+Y
KILL DIC,H
SET LRURG=X
+5 QUIT
SAMP ;Edit Collection sample and specimen
+1 SET LRUNQ=$PIECE(^LAB(60,LRTST,0),"^",8)
SET (J,N1)=$ORDER(^(3,0))
SET LRCSN=1
+2 IF "ILC"[LRZX(1)
SET LRSAMP=$PIECE(^LAB(60,LRTST,0),"^",9)
WRITE !,"Lab will collect ",$PIECE(^LAB(62,LRSAMP,0),"^")," ",$PIECE(^(0),"^",3)
GOTO SPEC
+3 IF N1
SET LRCS(1)=+^LAB(60,LRTST,3,N1,0)
+4 IF N1&(LRUNQ)
SET X=$PIECE(^LAB(62,LRCS(1),0),"^")
WRITE !,"The Sample Is "_X_" "_$PIECE(^(0),"^",3)
SET LRSAMP=LROSAMP
GOTO SPEC
+5 IF N1
FOR
SET J=$ORDER(^LAB(60,LRTST,3,J))
IF J<1
QUIT
SET LRCSN=LRCSN+1
SET LRCS(LRCSN)=+^(J,0)
+6 IF LRCSN>1
GOTO SAMP2
SAMP1 IF LRCSN<2
SET DIC="^LAB(62,"
SET DIC(0)="EMOQ"
SET D="B"
WRITE !,"COLLECTION SAMPLE: "_$PIECE(^LAB(62,LROSAMP,0),"^")_"//"
READ X:DTIME
IF X["?"
DO IX^DIC
IF X["?"
GOTO SAMP1
IF X["^"!(X="")!('$TEST)
SET LRSAMP=LROSAMP
GOTO SPEC
+1 IF LRCSN<2
DO ^DIC
KILL DIC
IF '($DATA(DUOUT)!$DATA(DTOUT))&(Y<0)
GOTO SAMP1
IF $DATA(DTOUT)!$DATA(DUOUT)
IF X="^^"
SET DIROUT=1
SET LRSAMP=LROSAMP
GOTO SAMP1
+2 SET LRSAMP=+Y
GOTO SPEC
SAMP2 IF LRCSN>1
WRITE !,"COLLECTION SAMPLE:"
FOR I=1:1:LRCSN
WRITE !,I," ",$PIECE(^LAB(62,LRCS(I),0),"^")," ",$PIECE(^(0),"^",3)
+1 WRITE !,"Choose one: "_$PIECE(^LAB(62,LROSAMP,0),"^")_"//"
READ X:DTIME
IF X["?"
GOTO SAMP2
IF X["^"!(X="")!('$TEST)
SET LRSAMP=LROSAMP
GOTO SPEC
+2 IF '$DATA(LRCS(X))
WRITE $CHAR(7),!,"Type number 1-",LRCSN,!
HANG 1
GOTO SAMP2
+3 SET LRSAMP=$PIECE(LRCS(X),"^")
WRITE " "_$PIECE(^LAB(62,LRSAMP,0),"^")_$PIECE(^(0),"^",3)
GOTO SPEC
+4 QUIT
SPEC ;
+1 IF $PIECE(^LAB(62,LRSAMP,0),"^",2)'=""
SET LRSPEC=+$PIECE(^(0),"^",2)
QUIT
SPEC1 SET DIC="^LAB(61,"
SET DIC(0)="EMOQ"
SET D="E"
WRITE !!,"SITE SPECIMEN: "_$PIECE(^LAB(61,LROSPEC,0),"^")_"//"
READ X:DTIME
IF X["?"
DO IX^DIC
IF X["?"
GOTO SPEC1
IF X["^"!(X="")!('$TEST)
SET LRSPEC=LROSPEC
QUIT
+1 DO ^DIC
+2 KILL DIC
IF '($DATA(DUOUT)!$DATA(DTOUT))&(Y<0)
GOTO SPEC1
IF $DATA(DTOUT)!$DATA(DUOUT)
IF X="^^"
SET DIROUT=1
SET LRSPEC=LROSPEC
QUIT
+3 SET LRSPEC=+Y
+4 QUIT
RCOM ;Edit comment
+1 WRITE !!,"This is the existing comment "
+2 SET I=0
FOR
SET I=$ORDER(^XUTL("OR",$JOB,"COM",LROOST,LROXZ,LRSAMP,LRSPEC,LROCNT,I))
IF I<1
QUIT
SET TEXT=^(I)
WRITE TEXT,!
+3 KILL TEXT
WRITE !,"Do you want to change the comment for this order? "
SET %=2
DO YN^DICN
IF %=0
GOTO RCOM
+4 IF %'=1
IF ((LROST'=LROOST)!(LRZX(1)'=LROXZ))
MERGE ^XUTL("OR",$JOB,"COM",LROST,LRZX(1),LRSAMP,LRSPEC,LROCNT)=^XUTL("OR",$JOB,"COM",LROOST,LROXZ,LRSAMP,LRSPEC,LROCNT)
QUIT
+5 SET LRSX=LROCNT
KILL ^XUTL("OR",$JOB,"COM",LROOST,LROXZ,LRSAMP,LRSPEC,LRSX)
DO RCOM^LRXO2
+6 QUIT
