source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRORDST.m@ 1253

Last change on this file since 1253 was 613, checked in by George Lilly, 16 years ago

initial load of WorldVistAEHR
File size: 4.9 KB
RevLine 
[613]1LRORDST ;SLC/CJS/WTY - SET THE ORDER AND ACCESSION ;5/16/05
2 ;;5.2;LAB SERVICE;**100,107,121,153,202,290,291,359,362**;Sep 27, 1994;Build 11
3 ;Called to create orders and accessions from local LROT array
4 D DT
5 K ZTSK
6 I $P(LRPARAM,U,4),'$D(LRNOLABL),'$D(LRTJ),LRORDR="" D ^LRLABLIO
7 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
8 ;
9 I $D(LRLABLIO),$D(LRLBL) D
10 . S ZTRTN="ENT^LRLABLD",ZTDESC="LAB LABELS",ZTDTH=$H
11 . S ZTIO=LRLABLIO,ZTSAVE("LRLBL(")=""
12 . D ^%ZTLOAD K LRLBL
13 ;
14 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
15 K LRLBL,ZTSK
16 ;Clean-up CIDC variables
17 K LRBEX,LRBEY,LRBEAR,LRBERF
18 Q
19 ;
20 ;
21ZX K:$G(LRORDR)'="P" LRCOM,LRTCOM
22 N I,COMB,LRCPRS
23 I $D(LRGCOM) S LRCCOM=LRGCOM D RCS^LRORD2
24 S LRSXN=0,I=0
25 F S I=$O(LROT(LRSAMP,LRSPEC,I)) Q:I<1 S LRSXN=LRSXN+1
26 L +^LRO(69,LRODT,1)
27 S LRSN=1+$P($G(^LRO(69,LRODT,1,0)),U,3)
28 S LRSUM=1+$P($G(^LRO(69,LRODT,1,0)),U,4)
29ZSN N I
30 F Q:'$D(^LRO(69,LRODT,1,LRSN,0)) S LRSN=LRSN+1
31 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)
32 S ^LRO(69,LRODT,1,LRSN,2,0)="^69.03PA^"_LRSXN_U_LRSXN
33 S ^LRO(69,LRODT,1,0)="^69.01PA^"_LRSN_U_LRSUM
34 L -^LRO(69,LRODT,1)
35 S ^LRO(69,LRODT,1,"AA",LRDFN,LRSN)=""
36 S ^LRO(69,LRODT,1,"AC",LRLLOC,LRSN)=""
37 S LROT(LRSAMP,LRSPEC,"SN")=LRSN
38 S ^LRO(69,"D",LRDFN,LRODT,LRSN)=""
39 S COMB=$P($G(^LRO(69,LRODT,1,LRSN,1)),"^",7)
40 I $S($G(LRORDR)="":1,$G(LRORDR)="P":1,1:0) D
41 . S $P(^LRO(69,LRODT,1,LRSN,1),"^")=$P(LRCDT,"^")
42 . S $P(^LRO(69,LRODT,1,LRSN,1),"^",2)=$P(LRCDT,"^",2)
43 . S $P(^LRO(69,LRODT,1,LRSN,1),"^",4)="C"
44 . S $P(^LRO(69,LRODT,1,LRSN,1),"^",8)=DUZ(2)
45 . ;S ^LRO(69,LRODT,1,LRSN,1)=LRCDT_"^^C^^^"_COMB_"^"_DUZ(2)
46 . I $G(LRORDR)'="P" S ^LRO(69,"AA",+$G(LRORD),LRODT_"|"_LRSN)=""
47 . ; PIECE 4 INDICATED COLLECTED (NOTE: LRCDT HAS 2 PIECES)
48 I LRSPEC'="" S ^LRO(69,LRODT,1,LRSN,4,0)="^69.02PA^1^1",^(1,0)=LRSPEC
49 S ^LRO(69,LRODT,1,LRSN,.1)=LRORD,^LRO(69,"C",+LRORD,LRODT,LRSN)="",LRJ=0
50 F LRTN=1:1 S LRJ=$O(LROT(LRSAMP,LRSPEC,LRJ)) Q:LRJ<1 D ZSN1
51 I $D(LRCOM(LRSAMP,LRSPEC)),LRCOM(LRSAMP,LRSPEC) D
52 . N I
53 . S X=LRCOM(LRSAMP,LRSPEC)
54 . S ^LRO(69,LRODT,1,LRSN,6,0)="^69.04W^"_X_U_X
55 . F I=1:1:X S ^LRO(69,LRODT,1,LRSN,6,I,0)=LRCOM(LRSAMP,LRSPEC,I)
56 D NEW^LR7OB1(LRODT,LRSN,"SN",$G(LRNATURE),.LRCPRS)
57 I LRORDR="LC"!(LRORDR="I") D
58 . S ION=$P($G(^LAB(69.9,1,3.5,+DUZ(2),0)),U,2)
59 . S:ION="" ION=$P($G(^LAB(69.9,1,3)),U,4)
60 . I ION'="",(LRORDR="LC"!(LRORDR="I")) D ^LROW2P
61 I LRORDR="I" S ION=$P($G(^LAB(69.9,1,7,DUZ(2),0)),U,3) I ION'="" D ^LROW2P
62 I $S(LRORDR="":1,LRORDR="P":1,1:0) D ^LRWLST
63 Q
64 ;
65ZSN1 ;
66 N LRORIFN
67 S LRTSTS=LROT(LRSAMP,LRSPEC,LRJ),LRCPRS(LRTSTS)=""
68 S ^LRO(69,LRODT,1,LRSN,2,LRTN,0)=LRTSTS_"^"_$S($D(LROT(LRSAMP,LRSPEC,LRJ,1)):LROT(LRSAMP,LRSPEC,LRJ,1),1:LROUTINE)
69 D:+LRDPF=2&($G(LRSS)'="BB")&('$$CHKINP^LRBEBA4(LRDFN,LRODT)) ;CIDC
70 .D SACC^LRBEBA2(LRODT,LRSN,LRTN,LRSAMP,LRSPEC,LRTSTS,.LRBEX)
71 I $G(LRORIFN) S $P(^LRO(69,LRODT,1,LRSN,2,LRTN,0),"^",7)=LRORIFN ;OE/RR 2.5
72 S $P(^LRO(69,LRODT,1,LRSN,2,LRTN,0),"^",9,10)="IP^L"
73 S ^LRO(69,LRODT,1,LRSN,2,"B",LRTSTS,LRTN)=""
74 S ^LRO(69,"AT",LRDFN,LRTSTS,LRSPEC,LRODT)="",^(-LRODT)=""
75 D RCOM:$D(LROT(LRSAMP,LRSPEC,LRJ,2))
76 D:$O(LRTCOM(LRTSTS,0)) TCOM^LROW2A(LRTSTS)
77 Q
78 ;
79 ;
80RCOM ; Required comment
81 N LRTSTN,LRTEST
82 S LRTSTN=1,LRTEST(LRTSTN)=LRTSTS
83 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
84 S LREXP=LROT(LRSAMP,LRSPEC,LRJ,2)
85 D RCS^LRORD2,RCOM^LRORD2
86 I $G(LRKIL) S DA(1)=LRODT,DA=LRSN,DIK="^LRO(69,"_DA(1)_",1," D ^DIK Q
87 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
88 Q
89 ;
90 ;
91OLD ; to allow unchanged routines to still work, from LROE1, LRPHSET1
92 N LRNT
93 D DT,NOW^%DTC
94 S LRNT=%
95 I $P(LRPARAM,U,4),'$D(LRNOLABL),'$D(LRTJ) D ^LRLABLIO
96 D ^LRWLST
97 Q
98 ;
99 ;
100WCP Q:$D(LRNCWL)
101 S:$D(LRORDER) ION=LRORDER
102 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
103WCP2 S LRORDER=ION
104 I IO(0)=IO R !!,"Press RETURN to continue...",X:DTIME S IOP=LRORDER,%ZIS="" D ^%ZIS D ENT2^LROW2P Q
105 I IO'=IO(0) D ^LROW2P Q
106 Q
107 ;
108 ;
109DT S DT=$$DT^XLFDT()
110 Q
111 ;
112 ;
113WCP1 S %ZIS="NQ",%ZIS("A")="ORDER COPY DEVICE:"
114 D ^%ZIS
115 Q:POP
116 G WCP2
117 ;
118 ;
119OR ;OE/RR 2.5
120 Q ;Following logic not required - 2.5 is obsolete version
121 N LRORDR
122 Q:$G(LRORDRR)="R"
123 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:"")
124 D SET^LROR
125 Q
Note: See TracBrowser for help on using the repository browser.