source: FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LRLABLD0.m@ 794

Last change on this file since 794 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 5.7 KB
Line 
1LRLABLD0 ;DALOI/FHS/DRH/JMC - LABELS ON DEMAND FOR FUTURE LAB COLLECT ;8/29/94 12:36
2 ;;5.2;LAB SERVICE;**1,65,121,161,218**;Sep 27, 1994
3EN ;
4 W !?5,"Future Lab, Immediate, Ward Collect and Send Patient Orders"
5 W !?5,"Enter each date to print separately",!!
6 N %DT,%ZIS,DIR,DIRUT,DTOUT,DUOUT,LRBATCH,LRCHLOC,LRCT0,LRDTC,X,Y,ZTSK
7 S (LN,LRSTOP,CNT,LREND)=0,(LRLOCF,LRCHLOC)="",LRBATCH=1
8 S DT=$$DT^XLFDT
9 S %DT("A")="Print for what date(s): ",%DT="AEFX"
10 S %DT(0)=DT ; Only allow future dates( >=DT)
11 F D ^%DT Q:Y<1 S LRCT0(Y)="" I '$O(^LRO(69,+Y,1,0)) W !?10,"No Orders For "_$$FMTE^XLFDT(Y) K LRCT0(Y)
12 I '$O(LRCT0(0)) W !!?10,"Nothing selected ",!,$C(7) G END
13 D LRPICK G:$G(LREND) END
14 K DIR
15 S DIR(0)="S^1:Selected Locations;2:All Locations"
16 S DIR("A")="Choose one of the following",DIR("?")="Enter 1 or 2."
17 D ^DIR
18 I $D(DIRUT) D END Q
19 S LRCHLOC=Y
20SELLOC I LRCHLOC=1 D
21 . N DIC,DTOUT,DUOUT,X,Y
22 . S DIC="^SC(",DIC(0)="AEMQZ"
23 . F D Q:Y<0
24 . . D ^DIC
25 . . I $D(DUOUT)!($D(DTOUT)) S LREND=1
26 . . I Y>0 S LRLOCF(+Y)=$P(Y(0),U)
27 . I '$O(LRLOCF(0)) W !!?10,"No Locations Selected ",$C(7) S LREND=1
28 I LREND D END Q
29 D SELCOLTY
30 I LREND D END Q
31 S %ZIS="Q" D ^%ZIS G END:POP
32 I $D(IO("Q")) D Q
33 . N LRION
34 . S LRION=ION
35 . S ZTSAVE("LR*")="",ZTRTN="QUE^LRLABLD0",ZTDESC="Print future collection labels"
36 . D ^%ZTLOAD,^%ZISC
37 . W !?10,$S($G(ZTSK):"Queued to "_LRION,1:"Task NOT queued"),!
38 . D END
39 ;
40QUE ; Tasked entry and interactive point.
41 K ^TMP($J),LRDTC
42 S ^TMP($J)=$$NOW^XLFDT_"^"_$$FMADD^XLFDT(DT,1,0,0,0)
43 S (LN,LRSTOP,CNT,LRRB)=0
44 S LRODT=0
45 F S LRODT=$O(LRCT0(LRODT)) Q:LRODT="" D
46 . S LRSN=0
47 . F S LRSN=$O(^LRO(69,LRODT,1,LRSN)) Q:LRSN<1 D
48 . . N LREND
49 . . S LRSN(0)=$G(^LRO(69,LRODT,1,LRSN,0)),LRSN(1)=$G(^LRO(69,LRODT,1,LRSN,1))
50 . . ; Skip lab controls
51 . . I $P($G(^LR(+LRSN(0),0)),"^",2)=62.3 Q
52 . . ; Not selected location
53 . . I $O(LRLOCF(0)),'$D(LRLOCF(+$P(LRSN(0),U,9))) Q
54 . . ; No collection type
55 . . I $P(LRSN(0),U,4)="" Q
56 . . ; Not selected collection type.
57 . . I '$D(LRCOLTY($P(LRSN(0),U,4))) Q
58 . . S LREND=0 D CHK^LRLABLDS Q:LREND
59 . . S LRDFN=+LRSN(0) D BLDTMP
60 D ^LRLABELF
61 D END^LRLABELF
62 Q
63 ;
64SETUP ; Called by LRLABELF
65 S Y2=1,LRRB=0,N=1
66 S (Y1,Y)=LRCT
67 S LRDAT=$TR($$FMTE^XLFDT(LRCT,"2M"),"@"," ") ; Date/time with "@" --> " "
68 S NODE=$G(^LRO(69,LRODT,1,LRSN,0)) Q:'$L(NODE) S LRCE=$G(^(.1))
69 S LRCLTY=$P(NODE,U,4)
70 S LRDFN=+NODE,DFN=$P($G(^LR(LRDFN,0)),U,3) Q:'DFN S LRDPF=$P(^(0),U,2),LRINFW=$G(^(.091))
71 D PT^LRX
72 S LRLLOC=$P(NODE,U,7),LRTVOL=0
73 S LRTJ=$P(NODE,U,3)
74 I '$G(LRSING),$G(LRNEWL)'=LRLLOC D SEP
75 S LRTJDATA=$S($D(^LAB(62,+LRTJ,0)):^(0),1:"")
76 S LRTOP=$P(LRTJDATA,U,3),S1=$P(LRTJDATA,U,4)
77 S S2=$P(LRTJDATA,U,5) D:LRTOP="" LRTOP
78 D T
79 S LRN=$S(+S1=0:1,1:LRTVOL\S1+$S(LRTVOL#S1:1,LRTVOL=0:1,1:0))+LRXL
80 D P
81 Q
82T ;
83 Q:LRODT'>0
84 K LRTS,LRURG
85 S LRURG0=9,(LRXL,T)=0
86 F S T=$O(^LRO(69,LRODT,1,LRSN,2,T)) Q:T<.5 D
87 . Q:'$G(^LRO(69,LRODT,1,LRSN,2,T,0)) S LRTV=^(0)
88 . I $P(LRTV,"^",11) Q
89 . D T1
90 . S LRTS(T)=$S($D(^LAB(60,+LRTV,.1)):$P(^(.1),U,1),1:"")
91 . S LRXL=LRXL+$P(^LAB(60,+LRTV,0),U,15) ;Extra labels
92 Q
93T1 ;
94 N X
95 S LRVOL="" S:$P(LRTV,U,2)<3 LRURG=1
96 I $P(LRTV,U,2),$P(LRTV,U,2)<LRURG0 S LRURG0=$P(LRTV,U,2)
97 S X=0 F S X=$O(^LAB(60,+LRTV,3,X)) Q:X<1 I +$G(^(X,0))=$P(NODE,U,3) S LRVOL=$P(^(0),U,4),LRTVOL=LRTVOL+LRVOL
98 Q
99LRTOP ;
100 S LRTOP=$G(^LRO(69,LRODT,1,LRSN,4,1,0)) ; Specimen from file #69
101 S T=$P($G(^LAB(62,+$P($G(NODE),U,3),0)),U,1) ; Collection sample from file #69
102 S LRTOP=$P($G(^LAB(61,+LRTOP,0)),U)
103 S LRTOP=T_$S(LRTOP'=T:" "_LRTOP,1:"")
104 Q
105P ;
106 I '$G(LRSING) D:$S('$D(LRNEWL):1,(LRNEWL'=LRLLOC):1,1:0) SEP
107 Q:LRN<1
108 N LRAA,LRBAR
109 S LRAA=0
110 D LBLTYP^LRLABLD
111 D LRBAR^LRLABLD
112 S LRACC=$P($P($$FMTE^XLFDT(LRCT,2),"@",2),":",1,2)_" "_LRCLTY
113 D UID^LRLABLD,BARID^LRLABLD ; Setup UID and barcode ID.
114 S LRURGA=$$URGA^LRLABLD(LRURG0) ; Setup urgency abbreviation
115 U IO
116 F LRI=1:1:LRN D
117 . S I=LRI,N=LRN ; Label routines use "I" and "N"
118 . N LRI,LRN
119 . S LRPREF=$S(S2="":"",LRTVOL>S2:"LARGE ",1:"SMALL "),LRTVOL=LRTVOL-S1
120 . D @LRLABEL
121 Q
122QUIT ;
123END ;
124 D END^LRLABELF
125 Q
126SEP ;
127 N LRAA,LRAN,LRACC,LRBAR,LRCE,LRURG0,LRXL
128 N PNM,LRDAT,LRRB,SSN,LRTOP,LRINFW,LRTS,LRPREF,LRUID,I,N
129 S:'$D(LRLLOC) LRLLOC="" S LRNEWL=LRLLOC
130 S PNM="*** "_LRLLOC_" ***"
131 N LRLLOC S LRLLOC="LAB"
132 S LRDAT="XX/XX/XX",LRAN="0000"
133 S SSN="000-00-0000",LRACC="*NEW LOC*",LRCE="000"
134 S LRRB=1,LRPREF="SMALL ",LRURG0=9
135 S LRTOP="TEST TUBE",LRTS(1)="DON'T USE",LRTS(2)="This label"
136 D LBLTYP^LRLABLD
137 D LRBAR^LRLABLD
138 D UID^LRLABLD,BARID^LRLABLD ; Setup UID and barcode ID.
139 S LRURGA=$$URGA^LRLABLD(LRURG0) ; Setup urgency abbreviation
140 S LRINFW=" ",I=1,N=2,LRXL=0
141 U IO
142 D @LRLABEL
143 Q
144 ;
145LRPICK ; Choose type of output
146 K LRPICK
147 N DIR,DIRUT,DTOUT,DUOUT,X,Y
148 S DIR(0)="SO^1:List;2:Labels",DIR("?")="Enter 1 or 2."
149 S DIR("A")="Print a list or labels"
150 D ^DIR
151 I $D(DIRUT) S LREND=1
152 E S LRPICK=Y
153 Q
154 ;
155SELCOLTY ; Select collection Type(s) to Print
156 N DIR,DIRUT,DTOUT,DUOUT,LRCNT,X,Y
157 W !
158 K LRCOLTY
159 S LRCOLTY="I:IMM. LAB COLLECT;LC:LAB COLLECT;SP:SEND PATIENT;WC:WARD COLLECT"
160 F I=1:1 Q:$P(LRCOLTY,";",I)="" D
161 . S LRCNT=I ; number of items
162 . S DIR("A",I)=$J(I,5)_" "_$P($P(LRCOLTY,";",I),":",2)_" ("_$P($P(LRCOLTY,";",I),":",1)_")"
163 S DIR("A",LRCNT+1)=" "
164 S DIR("A")="Select Collection Type(s)"
165 S DIR(0)="LO^1:"_LRCNT_":0"
166 D ^DIR
167 I $D(DIRUT) S LREND=1 Q
168 F I=1:1 Q:'$P(Y,",",I) S LRCOLTY($P($P(LRCOLTY,";",$P(Y,",",I)),":"))=$P($P(LRCOLTY,";",$P(Y,",",I)),":",2)
169 Q
170 ;
171BLDTMP ; Build TMP global with order info.
172 ; Called from above, LRLABLDS
173 N LRORDLOC
174 S DFN=+$P($G(^LR(LRDFN,0)),U,3),LRDPF=+$P(^(0),U,2)
175 I 'DFN!('LRDPF) Q
176 D PT^LRX
177 S LRORDLOC=$$GET1^DIQ(44,+$P(LRSN(0),U,9)_",",.01) ; Ordering location
178 I LRORDLOC="" S LRORDLOC="Unknown"
179 S ^TMP($J,"LR",LRODT,+$P(LRSN(0),U,8),$S($L(LRWRD):LRWRD_"/",1:"")_LRORDLOC,PNM,"*"_LRSN)=""
180 Q
Note: See TracBrowser for help on using the repository browser.