LROR6A ;SLC/DCM - EDIT UNRELEASED LAB ORDERS FOR OE/RR ;9/11/89 16:55 ;
;;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
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
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
D RETURN^ORX
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
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
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLROR6A 4693 printed Apr 09, 2024@21:16:57 Page 2
LROR6A ;SLC/DCM - EDIT UNRELEASED LAB ORDERS FOR OE/RR ;9/11/89 16:55 ;
+1 ;;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 WRITE !!,"Invalid time selected this will be returned to ",$SELECT(LRZX(1)["L":"Lab Collect",LRZX(1)["W":"Ward Collect",1:"Send Patient")
HANG 2
End DoDot:1
+8 IF LRZX(1)'="I"
DO EN^LRXO5
if LREND
Begin DoDot:1
+9 if LRZX(1)'="LC"!(LROXZ="LC")
QUIT
+10 SET LRZX(1)=LROXZ
+11 WRITE !!,"Invalid time selected this will be returned to ",$SELECT(LRZX(1)["W":"Ward Collect",1:"Send Patient")
HANG 2
End DoDot:1
if LREND
SET LROST=LROOST
SET LREND=0
KILL LRPREV
+12 DO SAMP
KILL DIC,LRCS,LRUNQ,N1,LRCSN
+13 DO URG
if LREND
SET LRURG=LROURG
SET LREND=0
+14 IF $DATA(^XUTL("OR",$JOB,"COM",LROOST,LROXZ,LRSAMP,LRSPEC,LROCNT))
IF $ORDER(^(LROCNT,0))
DO RCOM
SET LRFLG=1
+15 IF '$DATA(LRFLG)
SET LRSX=LROCNT
DO RCOM^LRXO2
+16 KILL LRFLG
DO SET^LROR6B
+17 DO RETURN^ORX
+18 KILL LROCNT,LROXZ,LROOST,LROURG,LROSAMP,LROSPEC,LRCNT,LRSPEC,LRSAMP,LRSX,LRZX,LREK,LRURG,LROST,LRTST,LRTSTNM,LRCS,LRCSN,LRPRAM,LROUTINE
QUIT
TYPE WRITE !!," (S)END patient to lab",!," (W)ARD collect & deliver",!," (L)AB blood team"
IF $PIECE($GET(^LAB(69.9,1,7,DUZ(2),0)),U,6)
WRITE !," (I)MMEDIATE LAB COLLECT"
+1 WRITE !,"Select: "_$SELECT(LROXZ["LC":"LAB",LROXZ["WC":"WARD",LROXZ["I":"IMMEDIATE",1:"SEND")_"//"
READ X:DTIME
IF X["^"!(X="")!('$TEST)
SET LREND=1
QUIT
+2 SET LRCTYPE="SsWwLl"
IF $PIECE($GET(^LAB(69.9,1,7,DUZ(2),0)),U,6)
SET LRCTYPE=LRCTYPE_"Ii"
+3 IF LRCTYPE'[X
WRITE !,"Enter 'S' for SEND TO LAB",!?6,"'W' for WARD COLLECT",!?6,"'L' for LAB BLOOD TEAM."
if LRCTYPE["I"
WRITE !?6,"'I' for Immediate Collect",!?6,"'^' to Exit."
GOTO TYPE
+4 SET LRZX(1)=$SELECT(X["W":"WC",X["w":"WC",X["S":"SP",X["s":"SP",X["I":"I",X["i":"I",1:"LC")
+5 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
+6 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
