LRORDST ;SLC/CJS/WTY - SET THE ORDER AND ACCESSION ;5/16/05
;;5.2;LAB SERVICE;**100,107,121,153,202,290,291,359,362**;Sep 27, 1994;Build 11
;Called to create orders and accessions from local LROT array
D DT
K ZTSK
I $P(LRPARAM,U,4),'$D(LRNOLABL),'$D(LRTJ),LRORDR="" D ^LRLABLIO
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
;
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 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)
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 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 ^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 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
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)
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
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
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
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRORDST 5162 printed Dec 13, 2024@02:18:59 Page 2
LRORDST ;SLC/CJS/WTY - SET THE ORDER AND ACCESSION ;5/16/05
+1 ;;5.2;LAB SERVICE;**100,107,121,153,202,290,291,359,362**;Sep 27, 1994;Build 11
+2 ;Called to create orders and accessions from local LROT array
+3 DO DT
+4 KILL ZTSK
+5 IF $PIECE(LRPARAM,U,4)
IF '$DATA(LRNOLABL)
IF '$DATA(LRTJ)
IF LRORDR=""
DO ^LRLABLIO
+6 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
+7 ;
+8 IF $DATA(LRLABLIO)
IF $DATA(LRLBL)
Begin DoDot:1
+9 SET ZTRTN="ENT^LRLABLD"
SET ZTDESC="LAB LABELS"
SET ZTDTH=$HOROLOG
+10 SET ZTIO=LRLABLIO
SET ZTSAVE("LRLBL(")=""
+11 DO ^%ZTLOAD
KILL LRLBL
End DoDot:1
+12 ;
+13 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
+14 KILL LRLBL,ZTSK
+15 ;Clean-up CIDC variables
+16 KILL LRBEX,LRBEY,LRBEAR,LRBERF
+17 QUIT
+18 ;
+19 ;
ZX if $GET(LRORDR)'="P"
KILL LRCOM,LRTCOM
+1 NEW I,COMB,LRCPRS
+2 IF $DATA(LRGCOM)
SET LRCCOM=LRGCOM
DO RCS^LRORD2
+3 SET LRSXN=0
SET I=0
+4 FOR
SET I=$ORDER(LROT(LRSAMP,LRSPEC,I))
if I<1
QUIT
SET LRSXN=LRSXN+1
+5 LOCK +^LRO(69,LRODT,1)
+6 SET LRSN=1+$PIECE($GET(^LRO(69,LRODT,1,0)),U,3)
+7 SET LRSUM=1+$PIECE($GET(^LRO(69,LRODT,1,0)),U,4)
ZSN NEW I
+1 FOR
if '$DATA(^LRO(69,LRODT,1,LRSN,0))
QUIT
SET LRSN=LRSN+1
+2 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)
+3 SET ^LRO(69,LRODT,1,LRSN,2,0)="^69.03PA^"_LRSXN_U_LRSXN
+4 SET ^LRO(69,LRODT,1,0)="^69.01PA^"_LRSN_U_LRSUM
+5 LOCK -^LRO(69,LRODT,1)
+6 SET ^LRO(69,LRODT,1,"AA",LRDFN,LRSN)=""
+7 SET ^LRO(69,LRODT,1,"AC",LRLLOC,LRSN)=""
+8 SET LROT(LRSAMP,LRSPEC,"SN")=LRSN
+9 SET ^LRO(69,"D",LRDFN,LRODT,LRSN)=""
+10 SET COMB=$PIECE($GET(^LRO(69,LRODT,1,LRSN,1)),"^",7)
+11 IF $SELECT($GET(LRORDR)="":1,$GET(LRORDR)="P":1,1:0)
Begin DoDot:1
+12 SET $PIECE(^LRO(69,LRODT,1,LRSN,1),"^")=$PIECE(LRCDT,"^")
+13 SET $PIECE(^LRO(69,LRODT,1,LRSN,1),"^",2)=$PIECE(LRCDT,"^",2)
+14 SET $PIECE(^LRO(69,LRODT,1,LRSN,1),"^",4)="C"
+15 SET $PIECE(^LRO(69,LRODT,1,LRSN,1),"^",8)=DUZ(2)
+16 ;S ^LRO(69,LRODT,1,LRSN,1)=LRCDT_"^^C^^^"_COMB_"^"_DUZ(2)
+17 IF $GET(LRORDR)'="P"
SET ^LRO(69,"AA",+$GET(LRORD),LRODT_"|"_LRSN)=""
+18 ; PIECE 4 INDICATED COLLECTED (NOTE: LRCDT HAS 2 PIECES)
End DoDot:1
+19 IF LRSPEC'=""
SET ^LRO(69,LRODT,1,LRSN,4,0)="^69.02PA^1^1"
SET ^(1,0)=LRSPEC
+20 SET ^LRO(69,LRODT,1,LRSN,.1)=LRORD
SET ^LRO(69,"C",+LRORD,LRODT,LRSN)=""
SET LRJ=0
+21 FOR LRTN=1:1
SET LRJ=$ORDER(LROT(LRSAMP,LRSPEC,LRJ))
if LRJ<1
QUIT
DO ZSN1
+22 IF $DATA(LRCOM(LRSAMP,LRSPEC))
IF LRCOM(LRSAMP,LRSPEC)
Begin DoDot:1
+23 NEW I
+24 SET X=LRCOM(LRSAMP,LRSPEC)
+25 SET ^LRO(69,LRODT,1,LRSN,6,0)="^69.04W^"_X_U_X
+26 FOR I=1:1:X
SET ^LRO(69,LRODT,1,LRSN,6,I,0)=LRCOM(LRSAMP,LRSPEC,I)
End DoDot:1
+27 DO NEW^LR7OB1(LRODT,LRSN,"SN",$GET(LRNATURE),.LRCPRS)
+28 IF LRORDR="LC"!(LRORDR="I")
Begin DoDot:1
+29 SET ION=$PIECE($GET(^LAB(69.9,1,3.5,+DUZ(2),0)),U,2)
+30 if ION=""
SET ION=$PIECE($GET(^LAB(69.9,1,3)),U,4)
+31 IF ION'=""
IF (LRORDR="LC"!(LRORDR="I"))
DO ^LROW2P
End DoDot:1
+32 IF LRORDR="I"
SET ION=$PIECE($GET(^LAB(69.9,1,7,DUZ(2),0)),U,3)
IF ION'=""
DO ^LROW2P
+33 IF $SELECT(LRORDR="":1,LRORDR="P":1,1:0)
DO ^LRWLST
+34 QUIT
+35 ;
ZSN1 ;
+1 NEW LRORIFN
+2 SET LRTSTS=LROT(LRSAMP,LRSPEC,LRJ)
SET LRCPRS(LRTSTS)=""
+3 SET ^LRO(69,LRODT,1,LRSN,2,LRTN,0)=LRTSTS_"^"_$SELECT($DATA(LROT(LRSAMP,LRSPEC,LRJ,1)):LROT(LRSAMP,LRSPEC,LRJ,1),1:LROUTINE)
+4 ;CIDC
if +LRDPF=2&($GET(LRSS)'="BB")&('$$CHKINP^LRBEBA4(LRDFN,LRODT))
Begin DoDot:1
+5 DO SACC^LRBEBA2(LRODT,LRSN,LRTN,LRSAMP,LRSPEC,LRTSTS,.LRBEX)
End DoDot:1
+6 ;OE/RR 2.5
IF $GET(LRORIFN)
SET $PIECE(^LRO(69,LRODT,1,LRSN,2,LRTN,0),"^",7)=LRORIFN
+7 SET $PIECE(^LRO(69,LRODT,1,LRSN,2,LRTN,0),"^",9,10)="IP^L"
+8 SET ^LRO(69,LRODT,1,LRSN,2,"B",LRTSTS,LRTN)=""
+9 SET ^LRO(69,"AT",LRDFN,LRTSTS,LRSPEC,LRODT)=""
SET ^(-LRODT)=""
+10 if $DATA(LROT(LRSAMP,LRSPEC,LRJ,2))
DO RCOM
+11 if $ORDER(LRTCOM(LRTSTS,0))
DO TCOM^LROW2A(LRTSTS)
+12 QUIT
+13 ;
+14 ;
RCOM ; Required comment
+1 NEW LRTSTN,LRTEST
+2 SET LRTSTN=1
SET LRTEST(LRTSTN)=LRTSTS
+3 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)
WRITE !,LRCCOM
+4 SET LREXP=LROT(LRSAMP,LRSPEC,LRJ,2)
+5 DO RCS^LRORD2
DO RCOM^LRORD2
+6 IF $GET(LRKIL)
SET DA(1)=LRODT
SET DA=LRSN
SET DIK="^LRO(69,"_DA(1)_",1,"
DO ^DIK
QUIT
+7 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
+8 QUIT
+9 ;
+10 ;
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 IF '$DATA(LRORDER)
KILL %ZIS
SET IOP="HOME"
SET %ZIS="NQ"
DO ^%ZIS
if POP
GOTO WCP1
SET X=ION
SET DIC(0)="EQ"
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
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 ;Following logic not required - 2.5 is obsolete version
QUIT
+2 NEW LRORDR
+3 if $GET(LRORDRR)="R"
QUIT
+4 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:"")
+5 DO SET^LROR
+6 QUIT
