source: FOIAVistA/trunk/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBCLABR.m

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

initial load of FOIAVistA 6/30/08 version

File size: 2.1 KB
Line 
1DVBCLABR ;ALB/GTS-557/THM-PRINT C&P LAB TEST RESULTS ; 9/6/91 1:40 PM
2 ;;2.7;AMIE;**11,42**;Apr 10, 1995
3 ;
4LAB N XX S XX=1
5 F Q:'$D(DVBCRALC(XX)) D
6 .S DVBCRALC=DVBCRALC(XX)
7 .S XX=XX+1 D LAB1
8 Q
9LAB1 ;print lab
10 S STAT=$P(^DVB(396.3,DA(1),0),U,18) Q:STAT["X" I '$D(DVBCRALC) D SETLAB^DVBCPRNT ; ** Set variable DVBCRALC
11 S LRDFN=$S($D(^DPT(DFN,"LR")):+^("LR"),1:0),DTREL=$P(^DVB(396.3,DA(1),0),U,14) Q:DTREL=""
12 ; ** 'CH' X-ref is for Chemistry tests, 'MI' X-ref is for Micro tests.
13 D RSET S DVBCW=1 F DVBCI=0:0 S LRIDT=$O(^LR(LRDFN,"CH",LRIDT)) Q:LRIDT=""!(LRIDT>LREDT) D LK
14 D RSET S DVBCW=2 F DVBCI=0:0 S LRIDT=$O(^LR(LRDFN,"MI",LRIDT)) Q:LRIDT=""!(LRIDT>LREDT) D LK
15 ;
16RAD ;print radiology
17 Q:'$D(^RADPT(0)) ;quit if not running radiology package
18 S RABDT=DVBCBDT,RAEDT=DTREL,RAHLOC=DVBCRALC D ^RAUTL3
19 K DVBCW,RABDT,RAEDT,RAHLOC
20 Q
21 ;
22REN I '$D(FF) D HOME^%ZIS S FF=IOF
23 ;
24REN1 W @FF,!,"Reprint Lab/X-Ray Results for C&P Exams",!!!
25 S DIC="^DVB(396.3,",DIC(0)="AEQM" D ^DIC I X=""!(X=U) G KILL^DVBCUTIL
26 I +Y>0 S DA(1)=+Y,DFN=$P(Y,U,2)
27 W !! S %ZIS="AEQ",%ZIS("A")="Output device: " D ^%ZIS K %ZIS G:POP KILL^DVBCUTIL
28 I $D(IO("Q")) S ZTRTN="REN2^DVBCLABR",ZTIO=ION,ZTDESC="C&P lab/radiology print" F I="DIC*","DA*","DFN" S ZTSAVE(I)=""
29 I $D(IO("Q")) D ^%ZTLOAD W:$D(ZTSK) !!,"Request queued",!! H 2 G KILL^DVBCUTIL
30REN2 U IO D SETLAB^DVBCPRNT,LAB S LKILL=1
31 Q:$G(DVBGUI) D:$D(ZTQUEUED) KILL^%ZTLOAD
32 G KILL^DVBCUTIL
33 ;
34RSET D:'$D(LRPARAM) DT^LRX,EN^LRPARAM S (LREND,LRSTOP)=0,LRCW=8,LRHF=1,LRFOOT=0,(LRONESPC,LRONETST)=""
35 S LRLAB=1,X1=DTREL,X2=-120 D C^%DTC S (DVBCBDT,LREDT)=X,LRSDT=DTREL,LRIDT=9999999-LRSDT,LREDT=9999999-LREDT D PT^LRX
36 Q
37 ;
38LK I DVBCW=1 S DVBCRLOC=$P(^LR(LRDFN,"CH",LRIDT,0),U,11)
39 I DVBCW=2 S DVBCRLOC=$P(^LR(LRDFN,"MI",LRIDT,0),U,8)
40 Q:DVBCRLOC="" ; * Quit if DVBCRLOC is NULL.
41 ;
42 ; ** NOTE: DVBCRALC=^Pointer to file 44^Pointer to file 44^
43 ; ** NOTE: DVBCRALC pointers come from file 396.1 C&P ROUTING LOCATION
44 ; ** DVBCRLOC is the REQUESTING LOCATION in the Lab Data File multiple
45 F ZJ=0:0 S ZJ=$O(^SC("C",DVBCRLOC,ZJ)) Q:ZJ="" S DVBCXLOC=U_ZJ_U I DVBCRALC[DVBCXLOC D:DVBCW=1 CH^LRRP2 D:DVBCW=2 MI^LRRP2 Q
46 K DVBCXLOC
Note: See TracBrowser for help on using the repository browser.