126 lines
4.9 KiB
Mathematica
126 lines
4.9 KiB
Mathematica
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
|