LRORDST ;SLC/CJS/WTY - SET THE ORDER AND ACCESSION ; 13-Oct-2017 14:04 ; MKK
;;5.2;LAB SERVICE;**1002,1003,1004,1009,100,107,121,1010,1011,1013,1015,153,202,1018,1019,290,291,359,362,1031,1032,1035,1041**;NOV 1, 1997;Build 23
;
;Called to create orders and accessions from local LROT array
;
EP ; EP
D DT
K ZTSK
; I $P(LRPARAM,U,4),'$D(LRNOLABL),'$D(LRTJ),LRORDR="" D ^LRLABLIO
;-----BEGIN IHS MODIFICATION LR*5.2*1018
I $P(LRPARAM,U,4),'$D(LRNOLABL),'$D(LRTJ),LRORDR="" D:'$G(BLRGUI) ^LRLABLIO
;-----END IHS MODIFICATION
;
F LRSAMP=-1:0 S LRSAMP=$O(LROT(LRSAMP)) Q:LRSAMP="" F LRSPEC=-1:0 S LRSPEC=$O(LROT(LRSAMP,LRSPEC)) Q:LRSPEC="" D ZX
;
M ^TMP("LRORDST",$J,"LROT")=LROT ; IHS/MSC/MKK - LR*5.2*1032
;
D COMPORD^BLRDIAG(LRODT,LRORD) ;IHS/ITSC/TPF 11/07/02 **1015** DIAGNSOSI/SYMPTOM LAB POV
;
D BUG1034F(LRORD) ; IHS/MSC/MKK - LR*5.2*1035 - Fix for Major Bug in LR*5.2*1034
;
K ^TMP("LRORDST",$J) ; IHS/MSC/MKK - LR*5.2*1032
;
I $D(LRLABLIO),$D(LRLBL) D
. S ZTRTN="ENT^LRLABLD",ZTDESC="LAB LABELS",ZTDTH=$H
. S ZTIO=LRLABLIO,ZTSAVE("LRLBL(")=""
. D ^%ZTLOAD K LRLBL
;
I $D(LRSLIP) F I1=0:0 S I1=$O(LROT(I1)) Q:I1<1 F I2=-1:0 S I2=$O(LROT(I1,I2)) Q:I2="" S LRSN=LROT(I1,I2,"SN") D WCP
;
K LRLBL,ZTSK
;Clean-up CIDC variables
K LRBEX,LRBEY,LRBEAR,LRBERF
Q
;
;
ZX ; EP
K:$G(LRORDR)'="P" LRCOM,LRTCOM
N I,COMB,LRCPRS
I $D(LRGCOM) S LRCCOM=LRGCOM D RCS^LRORD2
S LRSXN=0,I=0
F S I=$O(LROT(LRSAMP,LRSPEC,I)) Q:I<1 S LRSXN=LRSXN+1
; L +^LRO(69,LRODT,1)
L +^LRO(69,LRODT,1):5 ; IHS/MSC/MKK - LR*5.2*1032
S LRSN=1+$P($G(^LRO(69,LRODT,1,0)),U,3)
S LRSUM=1+$P($G(^LRO(69,LRODT,1,0)),U,4)
;
;
ZSN ; EP
N I
F Q:'$D(^LRO(69,LRODT,1,LRSN,0)) S LRSN=LRSN+1
S ^LRO(69,LRODT,1,LRSN,0)=LRDFN_"^"_DUZ_"^"_(+LRSAMP)_"^"_$S($L($G(LRLWC)):LRLWC,$L(LRORDR):LRORDR,1:"SP")_"^"_LRNT_"^"_LRPRAC_"^"_LRLLOC_"^"_LRODT_$S(+LRORDTIM:"."_LRORDTIM,1:"")_"^"_LROLLOC_"^^"_$G(LRORIFN)
S ^LRO(69,LRODT,1,LRSN,2,0)="^69.03PA^"_LRSXN_U_LRSXN
S ^LRO(69,LRODT,1,0)="^69.01PA^"_LRSN_U_LRSUM
L -^LRO(69,LRODT,1)
;
S:LRLLOC="" LRLLOC="." ; IHS/ANMC/CLS 08/18/96
S ^LRO(69,LRODT,1,"AA",LRDFN,LRSN)=""
S ^LRO(69,LRODT,1,"AC",LRLLOC,LRSN)=""
S LROT(LRSAMP,LRSPEC,"SN")=LRSN
S ^LRO(69,"D",LRDFN,LRODT,LRSN)=""
S COMB=$P($G(^LRO(69,LRODT,1,LRSN,1)),"^",7)
I $S($G(LRORDR)="":1,$G(LRORDR)="P":1,1:0) D
. S $P(^LRO(69,LRODT,1,LRSN,1),"^")=$P(LRCDT,"^")
. S $P(^LRO(69,LRODT,1,LRSN,1),"^",2)=$P(LRCDT,"^",2)
. S $P(^LRO(69,LRODT,1,LRSN,1),"^",4)="C"
. S $P(^LRO(69,LRODT,1,LRSN,1),"^",8)=DUZ(2)
. ;S ^LRO(69,LRODT,1,LRSN,1)=LRCDT_"^^C^^^"_COMB_"^"_DUZ(2)
. I $G(LRORDR)'="P" S ^LRO(69,"AA",+$G(LRORD),LRODT_"|"_LRSN)=""
. ; PIECE 4 INDICATED COLLECTED (NOTE: LRCDT HAS 2 PIECES)
;
I LRSPEC'="" S ^LRO(69,LRODT,1,LRSN,4,0)="^69.02PA^1^1",^(1,0)=LRSPEC
S ^LRO(69,LRODT,1,LRSN,.1)=LRORD,^LRO(69,"C",+LRORD,LRODT,LRSN)="",LRJ=0
F LRTN=1:1 S LRJ=$O(LROT(LRSAMP,LRSPEC,LRJ)) Q:LRJ<1 D ZSN1
;
I $D(LRCOM(LRSAMP,LRSPEC)),LRCOM(LRSAMP,LRSPEC) D
. N I
. S X=LRCOM(LRSAMP,LRSPEC)
. S ^LRO(69,LRODT,1,LRSN,6,0)="^69.04W^"_X_U_X
. F I=1:1:X S ^LRO(69,LRODT,1,LRSN,6,I,0)=LRCOM(LRSAMP,LRSPEC,I)
;
; D:BLRLOG ^BLREVTQ("C","O",$G(BLROPT),,LRODT_","_LRSN) ; IHS/DIR/MJL 09/20/99
D:+$G(BLRLOG) ^BLREVTQ("C","O",$G(BLROPT),,LRODT_","_LRSN) ; MSC/MKK - LR*5.2*1041
;
D NEW^LR7OB1(LRODT,LRSN,"SN",$G(LRNATURE),.LRCPRS)
I LRORDR="LC"!(LRORDR="I") D
. S ION=$P($G(^LAB(69.9,1,3.5,+DUZ(2),0)),U,2)
. S:ION="" ION=$P($G(^LAB(69.9,1,3)),U,4)
. I ION'="",(LRORDR="LC"!(LRORDR="I")) D ^LROW2P
I LRORDR="I" S ION=$P($G(^LAB(69.9,1,7,DUZ(2),0)),U,3) I ION'="" D ^LROW2P
; I $S(LRORDR="":1,LRORDR="P":1,1:0) D ^LRWLST
; ----- BEGIN IHS/ITSC/TPF **1015** 'SIGN OR SYMPTOM' LAB POV
; ABOVE COMMENTED OUT.
; THIS IS TO ACCOMODATE THE EDITING OF THE DIAGNOSIS ENTRY AFTER THE ENTIRE
; ORDER IS COMPLETE. THE CALL TO LRWLST IS DONE WITHIN BLRDIAG
; ----- END IHS/ITSC/TPF **1015** 'SIGN OR SYMPTOM' LAB POV
;
Q
;
;
ZSN1 ;
N LRORIFN
S LRTSTS=LROT(LRSAMP,LRSPEC,LRJ),LRCPRS(LRTSTS)=""
; S ^LRO(69,LRODT,1,LRSN,2,LRTN,0)=LRTSTS_"^"_$S($D(LROT(LRSAMP,LRSPEC,LRJ,1)):LROT(LRSAMP,LRSPEC,LRJ,1),1:LROUTINE)
;----- BEGIN IHS MODIFICATION LR*5.2*1018
S ^LRO(69,LRODT,1,LRSN,2,LRTN,0)=LRTSTS_"^"_$S($D(LROT(LRSAMP,LRSPEC,LRJ,1)):LROT(LRSAMP,LRSPEC,LRJ,1),$G(BLRGUI):LRURG,1:LROUTINE)
;----- END IHS MODIFICATION
D:+LRDPF=2&($G(LRSS)'="BB")&('$$CHKINP^LRBEBA4(LRDFN,LRODT)) ;CIDC
.D SACC^LRBEBA2(LRODT,LRSN,LRTN,LRSAMP,LRSPEC,LRTSTS,.LRBEX)
I $G(LRORIFN) S $P(^LRO(69,LRODT,1,LRSN,2,LRTN,0),"^",7)=LRORIFN ;OE/RR 2.5
S $P(^LRO(69,LRODT,1,LRSN,2,LRTN,0),"^",9,10)="IP^L"
S ^LRO(69,LRODT,1,LRSN,2,"B",LRTSTS,LRTN)=""
S ^LRO(69,"AT",LRDFN,LRTSTS,LRSPEC,LRODT)="",^(-LRODT)=""
D RCOM:$D(LROT(LRSAMP,LRSPEC,LRJ,2))
D:$O(LRTCOM(LRTSTS,0)) TCOM^LROW2A(LRTSTS)
Q
;
;
RCOM ; Required comment
N LRTSTN,LRTEST
S LRTSTN=1,LRTEST(LRTSTN)=LRTSTS
; S LRCCOM="~For Test: "_$P(^LAB(60,LRTSTS,0),U)_" "_$P(^LAB(62,LRSAMP,0),U) S:$P(^(0),U)'=$P(^LAB(61,LRSPEC,0),U) LRCCOM=LRCCOM_" "_$P(^LAB(61,LRSPEC,0),U) I $S('$D(DUZ("AG")):1,"ARMYAFN"'[DUZ("AG"):1,1:0) W !,LRCCOM
;----- BEGIN IHS MODIFICATION LR*5.2*1018
S LRCCOM="~For Test: "_$P(^LAB(60,LRTSTS,0),U)_" "_$P(^LAB(62,LRSAMP,0),U) S:$P(^(0),U)'=$P(^LAB(61,LRSPEC,0),U) LRCCOM=LRCCOM_" "_$P(^LAB(61,LRSPEC,0),U) I $S('$D(DUZ("AG")):1,"ARMYAFN"'[DUZ("AG"):1,1:0) W:'$G(BLRGUI) !,LRCCOM
;----- END IHS MODIFICATION
S LREXP=LROT(LRSAMP,LRSPEC,LRJ,2)
D RCS^LRORD2,RCOM^LRORD2
I $G(LRKIL) S DA(1)=LRODT,DA=LRSN,DIK="^LRO(69,"_DA(1)_",1," D ^DIK Q
I LRCCOM="",$D(LRCOM(LRSAMP,LRSPEC)) S X=+LRCOM(LRSAMP,LRSPEC) I $D(LRCOM(LRSAMP,LRSPEC,X)),LRCOM(LRSAMP,LRSPEC,X)["~For Test:" K LRCOM(LRSAMP,LRSPEC,X) S LRCOM(LRSAMP,LRSPEC)=X-1
Q
;
;
OLD ; to allow unchanged routines to still work, from LROE1, LRPHSET1
N LRNT
D DT,NOW^%DTC
S LRNT=%
I $P(LRPARAM,U,4),'$D(LRNOLABL),'$D(LRTJ) D ^LRLABLIO
D ^LRWLST
Q
;
;
WCP Q:$D(LRNCWL)
S:$D(LRORDER) ION=LRORDER
; I '$D(LRORDER) K %ZIS S IOP="HOME",%ZIS="NQ" D ^%ZIS G:POP WCP1 S X=ION,DIC(0)="EQ",DIC=3.5 D ^DIC G:Y<1 WCP1 G:'$D(^%ZIS(1,+Y,99)) WCP1 G:'$L($P(^(99),U)) WCP1 S IOP=$P(^%ZIS(1,$P(^(99),U),0),U),%ZIS="NQ" D ^%ZIS G:POP WCP1 K %ZIS,IOP
;----- BEGIN IHS/OIT/MKK MODIFICATION LR*5.2*1019 -- DIC(0)="EQX" fix
I '$D(LRORDER) K %ZIS S IOP="HOME",%ZIS="NQ" D ^%ZIS G:POP WCP1 S X=ION,DIC(0)="EQX",DIC=3.5 D ^DIC G:Y<1 WCP1 G:'$D(^%ZIS(1,+Y,99)) WCP1 G:'$L($P(^(99),U)) WCP1 S IOP=$P(^%ZIS(1,$P(^(99),U),0),U),%ZIS="NQ" D ^%ZIS G:POP WCP1 K %ZIS,IOP
;----- END IHS MODIFICATION LR*5.2*1019
WCP2 S LRORDER=ION
I IO(0)=IO R !!,"Press RETURN to continue...",X:DTIME S IOP=LRORDER,%ZIS="" D ^%ZIS D ENT2^LROW2P Q
I IO'=IO(0) D ^LROW2P Q
Q
;
;
DT S DT=$$DT^XLFDT()
Q
;
;
WCP1 S %ZIS="NQ",%ZIS("A")="ORDER COPY DEVICE:"
D ^%ZIS
Q:POP
G WCP2
;
;
OR ;OE/RR 2.5
; Q ;Following logic not required - 2.5 is obsolete version
I $$VER^LR7OU1>2.5 Q ; OE/RR 2.5 Logic put back in -- IHS/MSC/MKK - LR*5.2*1031
N LRORDR
Q:$G(LRORDRR)="R"
S LRY=$S($D(LROT(LRSAMP,LRSPEC,LRJ,1)):LROT(LRSAMP,LRSPEC,LRJ,1),1:LROUTINE),LRI=1,LRTEST(LRI)=LRTSTS_"^"_LRY,LRORDR=$S($L($G(LRLWC)):LRLWC,1:"")
D SET^LROR
Q
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1035
; There was a major bug regarding Multipurpose accessioning in LR*5.2*1034.
; This code is the fix, but it's not known, at this time, what change caused the problem.
; It deals with the improper SPECIMEN TYPE being stored into the Lab Data file during
; accessioning, even though the Accession file has the correct SPECIMEN.
BUG1034F(LRORD) ; EP
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRORD,U,XPARSYS,XQXFLG)
;
S LRODT=0
F S LRODT=$O(^LRO(69,"C",LRORD,LRODT)) Q:LRODT<1 D
. S LRSP=0
. F S LRSP=$O(^LRO(69,"C",LRORD,LRODT,LRSP)) Q:LRSP<1 D
.. S LROT=0
.. F S LROT=$O(^LRO(69,LRODT,1,LRSP,2,LROT)) Q:LROT<1 D
... S STR=$G(^LRO(69,LRODT,1,LRSP,2,LROT,0))
... S LRAD=+$P(STR,U,3),LRAA=+$P(STR,U,4),LRAN=+$P(STR,U,5)
... S LRSS=$P($G(^LRO(68,LRAA,0)),U,2)
... S LRDFN=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),LRIDT=+$P($G(^(3)),U,5)
... S LRSPEC=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0))
... S COLLSAMP=+$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0)),U,2)
... Q:LRSS'="BB"&(LRSS'="CH")&(LRSS'="MI")
... I LRSPEC,LRDFN,LRIDT,$L(LRSS) D
.... S $P(^LR(LRDFN,LRSS,LRIDT,0),U,5)=LRSPEC
.... S:LRSS="MI"!(LRSS="BB") $P(^LR(LRDFN,LRSS,LRIDT,0),U,11)=$S(COLLSAMP:COLLSAMP,1:"")
Q
LRORDST ;SLC/CJS/WTY - SET THE ORDER AND ACCESSION ; 13-Oct-2017 14:04 ; MKK
+1 ;;5.2;LAB SERVICE;**1002,1003,1004,1009,100,107,121,1010,1011,1013,1015,153,202,1018,1019,290,291,359,362,1031,1032,1035,1041**;NOV 1, 1997;Build 23
+2 ;
+3 ;Called to create orders and accessions from local LROT array
+4 ;
EP ; EP
+1 DO DT
+2 KILL ZTSK
+3 ; I $P(LRPARAM,U,4),'$D(LRNOLABL),'$D(LRTJ),LRORDR="" D ^LRLABLIO
+4 ;-----BEGIN IHS MODIFICATION LR*5.2*1018
+5 IF $PIECE(LRPARAM,U,4)
IF '$DATA(LRNOLABL)
IF '$DATA(LRTJ)
IF LRORDR=""
IF '$GET(BLRGUI)
DO ^LRLABLIO
+6 ;-----END IHS MODIFICATION
+7 ;
+8 FOR LRSAMP=-1:0
SET LRSAMP=$ORDER(LROT(LRSAMP))
IF LRSAMP=""
QUIT
FOR LRSPEC=-1:0
SET LRSPEC=$ORDER(LROT(LRSAMP,LRSPEC))
IF LRSPEC=""
QUIT
DO ZX
+9 ;
+10 ; IHS/MSC/MKK - LR*5.2*1032
MERGE ^TMP("LRORDST",$JOB,"LROT")=LROT
+11 ;
+12 ;IHS/ITSC/TPF 11/07/02 **1015** DIAGNSOSI/SYMPTOM LAB POV
DO COMPORD^BLRDIAG(LRODT,LRORD)
+13 ;
+14 ; IHS/MSC/MKK - LR*5.2*1035 - Fix for Major Bug in LR*5.2*1034
DO BUG1034F(LRORD)
+15 ;
+16 ; IHS/MSC/MKK - LR*5.2*1032
KILL ^TMP("LRORDST",$JOB)
+17 ;
+18 IF $DATA(LRLABLIO)
IF $DATA(LRLBL)
Begin DoDot:1
+19 SET ZTRTN="ENT^LRLABLD"
SET ZTDESC="LAB LABELS"
SET ZTDTH=$HOROLOG
+20 SET ZTIO=LRLABLIO
SET ZTSAVE("LRLBL(")=""
+21 DO ^%ZTLOAD
KILL LRLBL
End DoDot:1
+22 ;
+23 IF $DATA(LRSLIP)
FOR I1=0:0
SET I1=$ORDER(LROT(I1))
IF I1<1
QUIT
FOR I2=-1:0
SET I2=$ORDER(LROT(I1,I2))
IF I2=""
QUIT
SET LRSN=LROT(I1,I2,"SN")
DO WCP
+24 ;
+25 KILL LRLBL,ZTSK
+26 ;Clean-up CIDC variables
+27 KILL LRBEX,LRBEY,LRBEAR,LRBERF
+28 QUIT
+29 ;
+30 ;
ZX ; EP
+1 IF $GET(LRORDR)'="P"
KILL LRCOM,LRTCOM
+2 NEW I,COMB,LRCPRS
+3 IF $DATA(LRGCOM)
SET LRCCOM=LRGCOM
DO RCS^LRORD2
+4 SET LRSXN=0
SET I=0
+5 FOR
SET I=$ORDER(LROT(LRSAMP,LRSPEC,I))
IF I<1
QUIT
SET LRSXN=LRSXN+1
+6 ; L +^LRO(69,LRODT,1)
+7 ; IHS/MSC/MKK - LR*5.2*1032
LOCK +^LRO(69,LRODT,1):5
+8 SET LRSN=1+$PIECE($GET(^LRO(69,LRODT,1,0)),U,3)
+9 SET LRSUM=1+$PIECE($GET(^LRO(69,LRODT,1,0)),U,4)
+10 ;
+11 ;
ZSN ; EP
+1 NEW I
+2 FOR
IF '$DATA(^LRO(69,LRODT,1,LRSN,0))
QUIT
SET LRSN=LRSN+1
+3 SET ^LRO(69,LRODT,1,LRSN,0)=LRDFN_"^"_DUZ_"^"_(+LRSAMP)_"^"_$SELECT($LENGTH($GET(LRLWC)):LRLWC,$LENGTH(LRORDR):LRORDR,1:"SP")_"^"_LRNT_"^"_LRPRAC_"^"_LRLLOC_"^"_LRODT_$SELECT(+LRORDTIM:"."_LRORDTIM,1:"")_"^"_LROLLOC_"^^"_$GET(LRORIFN)
+4 SET ^LRO(69,LRODT,1,LRSN,2,0)="^69.03PA^"_LRSXN_U_LRSXN
+5 SET ^LRO(69,LRODT,1,0)="^69.01PA^"_LRSN_U_LRSUM
+6 LOCK -^LRO(69,LRODT,1)
+7 ;
+8 ; IHS/ANMC/CLS 08/18/96
IF LRLLOC=""
SET LRLLOC="."
+9 SET ^LRO(69,LRODT,1,"AA",LRDFN,LRSN)=""
+10 SET ^LRO(69,LRODT,1,"AC",LRLLOC,LRSN)=""
+11 SET LROT(LRSAMP,LRSPEC,"SN")=LRSN
+12 SET ^LRO(69,"D",LRDFN,LRODT,LRSN)=""
+13 SET COMB=$PIECE($GET(^LRO(69,LRODT,1,LRSN,1)),"^",7)
+14 IF $SELECT($GET(LRORDR)="":1,$GET(LRORDR)="P":1,1:0)
Begin DoDot:1
+15 SET $PIECE(^LRO(69,LRODT,1,LRSN,1),"^")=$PIECE(LRCDT,"^")
+16 SET $PIECE(^LRO(69,LRODT,1,LRSN,1),"^",2)=$PIECE(LRCDT,"^",2)
+17 SET $PIECE(^LRO(69,LRODT,1,LRSN,1),"^",4)="C"
+18 SET $PIECE(^LRO(69,LRODT,1,LRSN,1),"^",8)=DUZ(2)
+19 ;S ^LRO(69,LRODT,1,LRSN,1)=LRCDT_"^^C^^^"_COMB_"^"_DUZ(2)
+20 IF $GET(LRORDR)'="P"
SET ^LRO(69,"AA",+$GET(LRORD),LRODT_"|"_LRSN)=""
+21 ; PIECE 4 INDICATED COLLECTED (NOTE: LRCDT HAS 2 PIECES)
End DoDot:1
+22 ;
+23 IF LRSPEC'=""
SET ^LRO(69,LRODT,1,LRSN,4,0)="^69.02PA^1^1"
SET ^(1,0)=LRSPEC
+24 SET ^LRO(69,LRODT,1,LRSN,.1)=LRORD
SET ^LRO(69,"C",+LRORD,LRODT,LRSN)=""
SET LRJ=0
+25 FOR LRTN=1:1
SET LRJ=$ORDER(LROT(LRSAMP,LRSPEC,LRJ))
IF LRJ<1
QUIT
DO ZSN1
+26 ;
+27 IF $DATA(LRCOM(LRSAMP,LRSPEC))
IF LRCOM(LRSAMP,LRSPEC)
Begin DoDot:1
+28 NEW I
+29 SET X=LRCOM(LRSAMP,LRSPEC)
+30 SET ^LRO(69,LRODT,1,LRSN,6,0)="^69.04W^"_X_U_X
+31 FOR I=1:1:X
SET ^LRO(69,LRODT,1,LRSN,6,I,0)=LRCOM(LRSAMP,LRSPEC,I)
End DoDot:1
+32 ;
+33 ; D:BLRLOG ^BLREVTQ("C","O",$G(BLROPT),,LRODT_","_LRSN) ; IHS/DIR/MJL 09/20/99
+34 ; MSC/MKK - LR*5.2*1041
IF +$GET(BLRLOG)
DO ^BLREVTQ("C","O",$GET(BLROPT),,LRODT_","_LRSN)
+35 ;
+36 DO NEW^LR7OB1(LRODT,LRSN,"SN",$GET(LRNATURE),.LRCPRS)
+37 IF LRORDR="LC"!(LRORDR="I")
Begin DoDot:1
+38 SET ION=$PIECE($GET(^LAB(69.9,1,3.5,+DUZ(2),0)),U,2)
+39 IF ION=""
SET ION=$PIECE($GET(^LAB(69.9,1,3)),U,4)
+40 IF ION'=""
IF (LRORDR="LC"!(LRORDR="I"))
DO ^LROW2P
End DoDot:1
+41 IF LRORDR="I"
SET ION=$PIECE($GET(^LAB(69.9,1,7,DUZ(2),0)),U,3)
IF ION'=""
DO ^LROW2P
+42 ; I $S(LRORDR="":1,LRORDR="P":1,1:0) D ^LRWLST
+43 ; ----- BEGIN IHS/ITSC/TPF **1015** 'SIGN OR SYMPTOM' LAB POV
+44 ; ABOVE COMMENTED OUT.
+45 ; THIS IS TO ACCOMODATE THE EDITING OF THE DIAGNOSIS ENTRY AFTER THE ENTIRE
+46 ; ORDER IS COMPLETE. THE CALL TO LRWLST IS DONE WITHIN BLRDIAG
+47 ; ----- END IHS/ITSC/TPF **1015** 'SIGN OR SYMPTOM' LAB POV
+48 ;
+49 QUIT
+50 ;
+51 ;
ZSN1 ;
+1 NEW LRORIFN
+2 SET LRTSTS=LROT(LRSAMP,LRSPEC,LRJ)
SET LRCPRS(LRTSTS)=""
+3 ; S ^LRO(69,LRODT,1,LRSN,2,LRTN,0)=LRTSTS_"^"_$S($D(LROT(LRSAMP,LRSPEC,LRJ,1)):LROT(LRSAMP,LRSPEC,LRJ,1),1:LROUTINE)
+4 ;----- BEGIN IHS MODIFICATION LR*5.2*1018
+5 SET ^LRO(69,LRODT,1,LRSN,2,LRTN,0)=LRTSTS_"^"_$SELECT($DATA(LROT(LRSAMP,LRSPEC,LRJ,1)):LROT(LRSAMP,LRSPEC,LRJ,1),$GET(BLRGUI):LRURG,1:LROUTINE)
+6 ;----- END IHS MODIFICATION
+7 ;CIDC
IF +LRDPF=2&($GET(LRSS)'="BB")&('$$CHKINP^LRBEBA4(LRDFN,LRODT))
Begin DoDot:1
+8 DO SACC^LRBEBA2(LRODT,LRSN,LRTN,LRSAMP,LRSPEC,LRTSTS,.LRBEX)
End DoDot:1
+9 ;OE/RR 2.5
IF $GET(LRORIFN)
SET $PIECE(^LRO(69,LRODT,1,LRSN,2,LRTN,0),"^",7)=LRORIFN
+10 SET $PIECE(^LRO(69,LRODT,1,LRSN,2,LRTN,0),"^",9,10)="IP^L"
+11 SET ^LRO(69,LRODT,1,LRSN,2,"B",LRTSTS,LRTN)=""
+12 SET ^LRO(69,"AT",LRDFN,LRTSTS,LRSPEC,LRODT)=""
SET ^(-LRODT)=""
+13 IF $DATA(LROT(LRSAMP,LRSPEC,LRJ,2))
DO RCOM
+14 IF $ORDER(LRTCOM(LRTSTS,0))
DO TCOM^LROW2A(LRTSTS)
+15 QUIT
+16 ;
+17 ;
RCOM ; Required comment
+1 NEW LRTSTN,LRTEST
+2 SET LRTSTN=1
SET LRTEST(LRTSTN)=LRTSTS
+3 ; S LRCCOM="~For Test: "_$P(^LAB(60,LRTSTS,0),U)_" "_$P(^LAB(62,LRSAMP,0),U) S:$P(^(0),U)'=$P(^LAB(61,LRSPEC,0),U) LRCCOM=LRCCOM_" "_$P(^LAB(61,LRSPEC,0),U) I $S('$D(DUZ("AG")):1,"ARMYAFN"'[DUZ("AG"):1,1:0) W !,LRCCOM
+4 ;----- BEGIN IHS MODIFICATION LR*5.2*1018
+5 SET LRCCOM="~For Test: "_$PIECE(^LAB(60,LRTSTS,0),U)_" "_$PIECE(^LAB(62,LRSAMP,0),U)
IF $PIECE(^(0),U)'=$PIECE(^LAB(61,LRSPEC,0),U)
SET LRCCOM=LRCCOM_" "_$PIECE(^LAB(61,LRSPEC,0),U)
IF $SELECT('$DATA(DUZ("AG")):1,"ARMYAFN"'[DUZ("AG"):1,1:0)
IF '$GET(BLRGUI)
WRITE !,LRCCOM
+6 ;----- END IHS MODIFICATION
+7 SET LREXP=LROT(LRSAMP,LRSPEC,LRJ,2)
+8 DO RCS^LRORD2
DO RCOM^LRORD2
+9 IF $GET(LRKIL)
SET DA(1)=LRODT
SET DA=LRSN
SET DIK="^LRO(69,"_DA(1)_",1,"
DO ^DIK
QUIT
+10 IF LRCCOM=""
IF $DATA(LRCOM(LRSAMP,LRSPEC))
SET X=+LRCOM(LRSAMP,LRSPEC)
IF $DATA(LRCOM(LRSAMP,LRSPEC,X))
IF LRCOM(LRSAMP,LRSPEC,X)["~For Test:"
KILL LRCOM(LRSAMP,LRSPEC,X)
SET LRCOM(LRSAMP,LRSPEC)=X-1
+11 QUIT
+12 ;
+13 ;
OLD ; to allow unchanged routines to still work, from LROE1, LRPHSET1
+1 NEW LRNT
+2 DO DT
DO NOW^%DTC
+3 SET LRNT=%
+4 IF $PIECE(LRPARAM,U,4)
IF '$DATA(LRNOLABL)
IF '$DATA(LRTJ)
DO ^LRLABLIO
+5 DO ^LRWLST
+6 QUIT
+7 ;
+8 ;
WCP IF $DATA(LRNCWL)
QUIT
+1 IF $DATA(LRORDER)
SET ION=LRORDER
+2 ; I '$D(LRORDER) K %ZIS S IOP="HOME",%ZIS="NQ" D ^%ZIS G:POP WCP1 S X=ION,DIC(0)="EQ",DIC=3.5 D ^DIC G:Y<1 WCP1 G:'$D(^%ZIS(1,+Y,99)) WCP1 G:'$L($P(^(99),U)) WCP1 S IOP=$P(^%ZIS(1,$P(^(99),U),0),U),%ZIS="NQ" D ^%ZIS G:POP WCP1 K %ZIS,IOP
+3 ;----- BEGIN IHS/OIT/MKK MODIFICATION LR*5.2*1019 -- DIC(0)="EQX" fix
+4 IF '$DATA(LRORDER)
KILL %ZIS
SET IOP="HOME"
SET %ZIS="NQ"
DO ^%ZIS
IF POP
GOTO WCP1
SET X=ION
SET DIC(0)="EQX"
SET DIC=3.5
DO ^DIC
IF Y<1
GOTO WCP1
IF '$DATA(^%ZIS(1,+Y,99))
GOTO WCP1
IF '$LENGTH($PIECE(^(99),U))
GOTO WCP1
SET IOP=$PIECE(^%ZIS(1,$PIECE(^(99),U),0),U)
SET %ZIS="NQ"
DO ^%ZIS
IF POP
GOTO WCP1
KILL %ZIS,IOP
+5 ;----- END IHS MODIFICATION LR*5.2*1019
WCP2 SET LRORDER=ION
+1 IF IO(0)=IO
READ !!,"Press RETURN to continue...",X:DTIME
SET IOP=LRORDER
SET %ZIS=""
DO ^%ZIS
DO ENT2^LROW2P
QUIT
+2 IF IO'=IO(0)
DO ^LROW2P
QUIT
+3 QUIT
+4 ;
+5 ;
DT SET DT=$$DT^XLFDT()
+1 QUIT
+2 ;
+3 ;
WCP1 SET %ZIS="NQ"
SET %ZIS("A")="ORDER COPY DEVICE:"
+1 DO ^%ZIS
+2 IF POP
QUIT
+3 GOTO WCP2
+4 ;
+5 ;
OR ;OE/RR 2.5
+1 ; Q ;Following logic not required - 2.5 is obsolete version
+2 ; OE/RR 2.5 Logic put back in -- IHS/MSC/MKK - LR*5.2*1031
IF $$VER^LR7OU1>2.5
QUIT
+3 NEW LRORDR
+4 IF $GET(LRORDRR)="R"
QUIT
+5 SET LRY=$SELECT($DATA(LROT(LRSAMP,LRSPEC,LRJ,1)):LROT(LRSAMP,LRSPEC,LRJ,1),1:LROUTINE)
SET LRI=1
SET LRTEST(LRI)=LRTSTS_"^"_LRY
SET LRORDR=$SELECT($LENGTH($GET(LRLWC)):LRLWC,1:"")
+6 DO SET^LROR
+7 QUIT
+8 ;
+9 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1035
+10 ; There was a major bug regarding Multipurpose accessioning in LR*5.2*1034.
+11 ; This code is the fix, but it's not known, at this time, what change caused the problem.
+12 ; It deals with the improper SPECIMEN TYPE being stored into the Lab Data file during
+13 ; accessioning, even though the Accession file has the correct SPECIMEN.
BUG1034F(LRORD) ; EP
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRORD,U,XPARSYS,XQXFLG)
+2 ;
+3 SET LRODT=0
+4 FOR
SET LRODT=$ORDER(^LRO(69,"C",LRORD,LRODT))
IF LRODT<1
QUIT
Begin DoDot:1
+5 SET LRSP=0
+6 FOR
SET LRSP=$ORDER(^LRO(69,"C",LRORD,LRODT,LRSP))
IF LRSP<1
QUIT
Begin DoDot:2
+7 SET LROT=0
+8 FOR
SET LROT=$ORDER(^LRO(69,LRODT,1,LRSP,2,LROT))
IF LROT<1
QUIT
Begin DoDot:3
+9 SET STR=$GET(^LRO(69,LRODT,1,LRSP,2,LROT,0))
+10 SET LRAD=+$PIECE(STR,U,3)
SET LRAA=+$PIECE(STR,U,4)
SET LRAN=+$PIECE(STR,U,5)
+11 SET LRSS=$PIECE($GET(^LRO(68,LRAA,0)),U,2)
+12 SET LRDFN=+$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
SET LRIDT=+$PIECE($GET(^(3)),U,5)
+13 SET LRSPEC=+$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0))
+14 SET COLLSAMP=+$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0)),U,2)
+15 IF LRSS'="BB"&(LRSS'="CH")&(LRSS'="MI")
QUIT
+16 IF LRSPEC
IF LRDFN
IF LRIDT
IF $LENGTH(LRSS)
Begin DoDot:4
+17 SET $PIECE(^LR(LRDFN,LRSS,LRIDT,0),U,5)=LRSPEC
+18 IF LRSS="MI"!(LRSS="BB")
SET $PIECE(^LR(LRDFN,LRSS,LRIDT,0),U,11)=$SELECT(COLLSAMP:COLLSAMP,1:"")
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+19 QUIT
