Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DVBCLABR

DVBCLABR.m

Go to the documentation of this file.
  1. DVBCLABR ;ALB/GTS-557/THM-PRINT C&P LAB TEST RESULTS ; 9/6/91 1:40 PM
  1. ;;2.7;AMIE;**11,42,193**;Apr 10, 1995;Build 84
  1. ;
  1. LAB N XX S XX=1
  1. F Q:'$D(DVBCRALC(XX)) D
  1. .S DVBCRALC=DVBCRALC(XX)
  1. .S XX=XX+1 D LAB1
  1. Q
  1. LAB1 ;print lab
  1. ;AJF;Request Status conversion
  1. S STAT=$P(^DVB(396.3,DA(1),0),U,18),STAT=$$RSTAT^DVBCUTL8(STAT)
  1. Q:STAT["X" I '$D(DVBCRALC) D SETLAB^DVBCPRNT ; ** Set variable DVBCRALC
  1. S LRDFN=$S($D(^DPT(DFN,"LR")):+^("LR"),1:0),DTREL=$P(^DVB(396.3,DA(1),0),U,14) Q:DTREL=""
  1. ; ** 'CH' X-ref is for Chemistry tests, 'MI' X-ref is for Micro tests.
  1. D RSET S DVBCW=1 F DVBCI=0:0 S LRIDT=$O(^LR(LRDFN,"CH",LRIDT)) Q:LRIDT=""!(LRIDT>LREDT) D LK
  1. D RSET S DVBCW=2 F DVBCI=0:0 S LRIDT=$O(^LR(LRDFN,"MI",LRIDT)) Q:LRIDT=""!(LRIDT>LREDT) D LK
  1. ;
  1. RAD ;print radiology
  1. Q:'$D(^RADPT(0)) ;quit if not running radiology package
  1. S RABDT=DVBCBDT,RAEDT=DTREL,RAHLOC=DVBCRALC D ^RAUTL3
  1. K DVBCW,RABDT,RAEDT,RAHLOC
  1. Q
  1. ;
  1. REN I '$D(FF) D HOME^%ZIS S FF=IOF
  1. ;
  1. REN1 W @FF,!,"Reprint Lab/X-Ray Results for C&P Exams",!!!
  1. S DIC="^DVB(396.3,",DIC(0)="AEQM" D ^DIC I X=""!(X=U) G KILL^DVBCUTIL
  1. I +Y>0 S DA(1)=+Y,DFN=$P(Y,U,2)
  1. W !! S %ZIS="AEQ",%ZIS("A")="Output device: " D ^%ZIS K %ZIS G:POP KILL^DVBCUTIL
  1. I $D(IO("Q")) S ZTRTN="REN2^DVBCLABR",ZTIO=ION,ZTDESC="C&P lab/radiology print" F I="DIC*","DA*","DFN" S ZTSAVE(I)=""
  1. I $D(IO("Q")) D ^%ZTLOAD W:$D(ZTSK) !!,"Request queued",!! H 2 G KILL^DVBCUTIL
  1. REN2 U IO D SETLAB^DVBCPRNT,LAB S LKILL=1
  1. Q:$G(DVBGUI) D:$D(ZTQUEUED) KILL^%ZTLOAD
  1. G KILL^DVBCUTIL
  1. ;
  1. RSET D:'$D(LRPARAM) DT^LRX,EN^LRPARAM S (LREND,LRSTOP)=0,LRCW=8,LRHF=1,LRFOOT=0,(LRONESPC,LRONETST)=""
  1. 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
  1. Q
  1. ;
  1. LK I DVBCW=1 S DVBCRLOC=$P(^LR(LRDFN,"CH",LRIDT,0),U,11)
  1. I DVBCW=2 S DVBCRLOC=$P(^LR(LRDFN,"MI",LRIDT,0),U,8)
  1. Q:DVBCRLOC="" ; * Quit if DVBCRLOC is NULL.
  1. ;
  1. ; ** NOTE: DVBCRALC=^Pointer to file 44^Pointer to file 44^
  1. ; ** NOTE: DVBCRALC pointers come from file 396.1 C&P ROUTING LOCATION
  1. ; ** DVBCRLOC is the REQUESTING LOCATION in the Lab Data File multiple
  1. 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
  1. K DVBCXLOC