LROR9 ;SLC/DCM - ADD TESTS TO AN EXISTING ORDER THRU OE/RR; 9/23/88 15:15 ;2/8/91 07:29 ;
;;5.2;LAB SERVICE;;Sep 27, 1994
EN Q:'$D(ORPK) S LRODT=$P(ORPK,"^"),LRSN=$P(ORPK,"^",2),LRTN=$P(ORPK,"^",3) I 'LRODT!('LRSN)!('LRTN) W !,"Cannot add to this order." Q
I '$D(^LRO(69,LRODT,1,LRSN,0)) W !,"Cannot add to this order." Q
S LR2ORD=1 I $D(^LRO(69,LRODT,1,LRSN,2,LRTN,0)),$P(^(0),"^",3) W !,"Tests have been accessioned, call the lab to add tests to the same order." G END
S LRADDTST="",LRORD=$P(^LRO(69,LRODT,1,LRSN,.1),"^") D:'$D(LRPARAM) EN^LRPARAM D PT,A
END K X3,T,LRADDTST,LRFLOG,LRIOZERO,LRGCOM,LRM,LRNCWL,LRORDER,LRORDTIM,LRORIFN,LRSSX,LRSTIK,LRSVSN,LRTSTNM,LRTXD,LRTXP,LRWPC,LRBED,LRCCOM,LRCDT,LRCOM,LRCS,LRCSN,LRCSP,LRCSS,LRCSX,LRDFN,LRDPF,LRDTO,LREND,LREXP,LRI,LRIO,LRLLOC,LRLWC
K LR2ORD,LRMAX,LRMOR,LRNN,LRODT,LRORD,LRPR,LRPRAC,LRSAMP,LRTSTN,LRSN,LRSNO,LRSPEC,LRSSP,LRTEST,LRTIME,LRTN,LRTP,LRTSN,LRTY,LRUR,LRUSI,LRUSNM,LRXS,LRXST,LRY,PNM,SEX,SSN,J,K,S,X,Y,LRSN1,LRSAME
K DIC,L,LRAA,LRAAO,LRACN0,LRAD,LRAN,LRCW,LRFOOT,LRHF,LRLAB,LRLL,LROD0,LROD1,LROD3,LROOS,LROS,LROSD,LRBLOOD,LRC,LRDT0,LRJ,LRMD,LRODTSV,LROR,LRORN,LRPARAM,LRPLASMA,LRSERUM,LRSNSV,LRTNSV,LRUNKNOW,LRUNQ,LRURG,LRURINE,LRWRD,LRZX,NOW,X1,X5
K LROT,LRROD,LRSAV,LRSORD,LRSS,LRTSTS,LRZ
Q
A S X=^LRO(69,LRODT,1,LRSN,0),LRSAMP=$P(X,"^",3),LRSPEC=$S($D(^(4,1,0)):+^(0),1:0) I LRSPEC,LRSAMP D B
K T S DA=0 F S DA=$O(^LRO(69,LRODT,1,"AA",LRDFN,DA)) Q:DA<1 I $S($D(^LRO(69,LRODT,1,DA,1)):$P(^(1),"^",4)'="U",1:1) S S=$S($D(^LRO(69,LRODT,1,DA,4,1,0)):+^(0),1:0) S I=0 F S I=$O(^LRO(69,LRODT,1,DA,2,I)) Q:I<1 S T(+^(I,0),DA)=S
D ADD^LROW
Q
B S I=0 F S I=$O(^LRO(69,LRODT,1,LRSN,2,I)) Q:I<1 S X3(+^(I,0),LRSAMP,LRSPEC)=""
Q
PT S LROR=$S($D(^LRO(69,LRODT,1,LRSN,0)):^(0),1:-1),LRDFN=+LROR I LRDFN<1 W " NO PATIENT" Q
S LRDPF=$P(^LR(LRDFN,0),"^",2),DFN=$P(^(0),"^",3) D PT^LRX
H 1 W !!,"ORDER #: ",LRORD,?30,"PATIENT: ",PNM,?60,"SSN: ",SSN
S Y=$S($D(^LRO(69,LRODT,1,LRSN,1)):+^(1),1:"") I Y D DD^LRX W !," DRAW TIME: ",Y
W ! S Y=$S($D(^LRO(69,LRODT,1,LRSN,3)):+^(3),1:"") I Y D DD^LRX W " LAB ARRIVAL: ",Y
W:$D(^DPT(DFN,.1)) ?40,"WARD: ",^(.1)
W:$P(LROR,"^",3) !," SPECIMEN: ",$S($D(^LAB(62,$P(LROR,"^",3),0)):$P(^(0),"^"),1:"??")
S L=+$P(^LRO(69,LRODT,1,LRSN,0),"^",6) I L S LRMD=$S($D(^VA(200,L,0)):$P(^(0),"^"),1:L) W ?30,"PHYSICIAN: ",LRMD
TST S I=0 F S I=$O(^LRO(69,LRODT,1,LRSN,2,I)) Q:I<1 D TEST
I $D(^LRO(69,LRODT,1,LRSN,1)),$L($P(^(1),"^",6)) W !,"COMMENT: ",$P(^(1),"^",6)
S I=0 F S I=$O(^LRO(69,LRODT,1,LRSN,6,I)) Q:I<1 W !,?3,^(I,0)
Q:'$D(LRADDTST) W !,"Is this the one" S %=1 D YN^DICN S LRADDTST=$S(%=1:LRORD,1:"") I %=1 S X=^LRO(69,LRODT,1,LRSN,0),LRLLOC=$P(X,"^",7),LROLLOC=$P(X,"^",9),LRORDTIM=$P($P(X,"^",8),".",2),LRPRAC=$P(X,"^",6),LRLWC=$P(X,"^",4)
Q
TEST S X=^LRO(69,LRODT,1,LRSN,2,I,0) S:$P(^(0),"^",3) LRNOP=1 W !," TEST: ",$S($D(^LAB(60,+X,0)):$P(^(0),"^"),1:"UNKNOWN"),?28," " S LRURG=+$P(X,"^",2) W $S($D(^LAB(62.05,LRURG,0)):$P(^(0),"^"),1:"ROUTINE")
W ?38," ",$S($D(^LRO(68,+$P(X,"^",4),0)):$P(^(0),"^"),1:""),?50," ",$P(X,"^",5)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLROR9 3101 printed Nov 22, 2024@17:28:53 Page 2
LROR9 ;SLC/DCM - ADD TESTS TO AN EXISTING ORDER THRU OE/RR; 9/23/88 15:15 ;2/8/91 07:29 ;
+1 ;;5.2;LAB SERVICE;;Sep 27, 1994
EN if '$DATA(ORPK)
QUIT
SET LRODT=$PIECE(ORPK,"^")
SET LRSN=$PIECE(ORPK,"^",2)
SET LRTN=$PIECE(ORPK,"^",3)
IF 'LRODT!('LRSN)!('LRTN)
WRITE !,"Cannot add to this order."
QUIT
+1 IF '$DATA(^LRO(69,LRODT,1,LRSN,0))
WRITE !,"Cannot add to this order."
QUIT
+2 SET LR2ORD=1
IF $DATA(^LRO(69,LRODT,1,LRSN,2,LRTN,0))
IF $PIECE(^(0),"^",3)
WRITE !,"Tests have been accessioned, call the lab to add tests to the same order."
GOTO END
+3 SET LRADDTST=""
SET LRORD=$PIECE(^LRO(69,LRODT,1,LRSN,.1),"^")
if '$DATA(LRPARAM)
DO EN^LRPARAM
DO PT
DO A
END KILL X3,T,LRADDTST,LRFLOG,LRIOZERO,LRGCOM,LRM,LRNCWL,LRORDER,LRORDTIM,LRORIFN,LRSSX,LRSTIK,LRSVSN,LRTSTNM,LRTXD,LRTXP,LRWPC,LRBED,LRCCOM,LRCDT,LRCOM,LRCS,LRCSN,LRCSP,LRCSS,LRCSX,LRDFN,LRDPF,LRDTO,LREND,LREXP,LRI,LRIO,LRLLOC,LRLWC
+1 KILL LR2ORD,LRMAX,LRMOR,LRNN,LRODT,LRORD,LRPR,LRPRAC,LRSAMP,LRTSTN,LRSN,LRSNO,LRSPEC,LRSSP,LRTEST,LRTIME,LRTN,LRTP,LRTSN,LRTY,LRUR,LRUSI,LRUSNM,LRXS,LRXST,LRY,PNM,SEX,SSN,J,K,S,X,Y,LRSN1,LRSAME
+2 KILL DIC,L,LRAA,LRAAO,LRACN0,LRAD,LRAN,LRCW,LRFOOT,LRHF,LRLAB,LRLL,LROD0,LROD1,LROD3,LROOS,LROS,LROSD,LRBLOOD,LRC,LRDT0,LRJ,LRMD,LRODTSV,LROR,LRORN,LRPARAM,LRPLASMA,LRSERUM,LRSNSV,LRTNSV,LRUNKNOW,LRUNQ,LRURG,LRURINE,LRWRD,LRZX,NOW,X1,X5
+3 KILL LROT,LRROD,LRSAV,LRSORD,LRSS,LRTSTS,LRZ
+4 QUIT
A SET X=^LRO(69,LRODT,1,LRSN,0)
SET LRSAMP=$PIECE(X,"^",3)
SET LRSPEC=$SELECT($DATA(^(4,1,0)):+^(0),1:0)
IF LRSPEC
IF LRSAMP
DO B
+1 KILL T
SET DA=0
FOR
SET DA=$ORDER(^LRO(69,LRODT,1,"AA",LRDFN,DA))
if DA<1
QUIT
IF $SELECT($DATA(^LRO(69,LRODT,1,DA,1)):$PIECE(^(1),"^",4)'="U",1:1)
SET S=$SELECT($DATA(^LRO(69,LRODT,1,DA,4,1,0)):+^(0),1:0)
SET I=0
FOR
SET I=$ORDER(^LRO(69,LRODT,1,DA,2,I))
if I<1
QUIT
SET T(+^(I,0),DA)=S
+2 DO ADD^LROW
+3 QUIT
B SET I=0
FOR
SET I=$ORDER(^LRO(69,LRODT,1,LRSN,2,I))
if I<1
QUIT
SET X3(+^(I,0),LRSAMP,LRSPEC)=""
+1 QUIT
PT SET LROR=$SELECT($DATA(^LRO(69,LRODT,1,LRSN,0)):^(0),1:-1)
SET LRDFN=+LROR
IF LRDFN<1
WRITE " NO PATIENT"
QUIT
+1 SET LRDPF=$PIECE(^LR(LRDFN,0),"^",2)
SET DFN=$PIECE(^(0),"^",3)
DO PT^LRX
+2 HANG 1
WRITE !!,"ORDER #: ",LRORD,?30,"PATIENT: ",PNM,?60,"SSN: ",SSN
+3 SET Y=$SELECT($DATA(^LRO(69,LRODT,1,LRSN,1)):+^(1),1:"")
IF Y
DO DD^LRX
WRITE !," DRAW TIME: ",Y
+4 WRITE !
SET Y=$SELECT($DATA(^LRO(69,LRODT,1,LRSN,3)):+^(3),1:"")
IF Y
DO DD^LRX
WRITE " LAB ARRIVAL: ",Y
+5 if $DATA(^DPT(DFN,.1))
WRITE ?40,"WARD: ",^(.1)
+6 if $PIECE(LROR,"^",3)
WRITE !," SPECIMEN: ",$SELECT($DATA(^LAB(62,$PIECE(LROR,"^",3),0)):$PIECE(^(0),"^"),1:"??")
+7 SET L=+$PIECE(^LRO(69,LRODT,1,LRSN,0),"^",6)
IF L
SET LRMD=$SELECT($DATA(^VA(200,L,0)):$PIECE(^(0),"^"),1:L)
WRITE ?30,"PHYSICIAN: ",LRMD
TST SET I=0
FOR
SET I=$ORDER(^LRO(69,LRODT,1,LRSN,2,I))
if I<1
QUIT
DO TEST
+1 IF $DATA(^LRO(69,LRODT,1,LRSN,1))
IF $LENGTH($PIECE(^(1),"^",6))
WRITE !,"COMMENT: ",$PIECE(^(1),"^",6)
+2 SET I=0
FOR
SET I=$ORDER(^LRO(69,LRODT,1,LRSN,6,I))
if I<1
QUIT
WRITE !,?3,^(I,0)
+3 if '$DATA(LRADDTST)
QUIT
WRITE !,"Is this the one"
SET %=1
DO YN^DICN
SET LRADDTST=$SELECT(%=1:LRORD,1:"")
IF %=1
SET X=^LRO(69,LRODT,1,LRSN,0)
SET LRLLOC=$PIECE(X,"^",7)
SET LROLLOC=$PIECE(X,"^",9)
SET LRORDTIM=$PIECE($PIECE(X,"^",8),".",2)
SET LRPRAC=$PIECE(X,"^",6)
SET LRLWC=$PIECE(X,"^",4)
+4 QUIT
TEST SET X=^LRO(69,LRODT,1,LRSN,2,I,0)
if $PIECE(^(0),"^",3)
SET LRNOP=1
WRITE !," TEST: ",$SELECT($DATA(^LAB(60,+X,0)):$PIECE(^(0),"^"),1:"UNKNOWN"),?28," "
SET LRURG=+$PIECE(X,"^",2)
WRITE $SELECT($DATA(^LAB(62.05,LRURG,0)):$PIECE(^(0),"^"),1:"ROUTINE")
+1 WRITE ?38," ",$SELECT($DATA(^LRO(68,+$PIECE(X,"^",4),0)):$PIECE(^(0),"^"),1:""),?50," ",$PIECE(X,"^",5)
+2 QUIT
