DVBCLABR ;ALB/GTS-557/THM-PRINT C&P LAB TEST RESULTS ; 9/6/91 1:40 PM
;;2.7;AMIE;**11,42,193**;Apr 10, 1995;Build 84
;
LAB N XX S XX=1
F Q:'$D(DVBCRALC(XX)) D
.S DVBCRALC=DVBCRALC(XX)
.S XX=XX+1 D LAB1
Q
LAB1 ;print lab
;AJF;Request Status conversion
S STAT=$P(^DVB(396.3,DA(1),0),U,18),STAT=$$RSTAT^DVBCUTL8(STAT)
Q:STAT["X" I '$D(DVBCRALC) D SETLAB^DVBCPRNT ; ** Set variable DVBCRALC
S LRDFN=$S($D(^DPT(DFN,"LR")):+^("LR"),1:0),DTREL=$P(^DVB(396.3,DA(1),0),U,14) Q:DTREL=""
; ** 'CH' X-ref is for Chemistry tests, 'MI' X-ref is for Micro tests.
D RSET S DVBCW=1 F DVBCI=0:0 S LRIDT=$O(^LR(LRDFN,"CH",LRIDT)) Q:LRIDT=""!(LRIDT>LREDT) D LK
D RSET S DVBCW=2 F DVBCI=0:0 S LRIDT=$O(^LR(LRDFN,"MI",LRIDT)) Q:LRIDT=""!(LRIDT>LREDT) D LK
;
RAD ;print radiology
Q:'$D(^RADPT(0)) ;quit if not running radiology package
S RABDT=DVBCBDT,RAEDT=DTREL,RAHLOC=DVBCRALC D ^RAUTL3
K DVBCW,RABDT,RAEDT,RAHLOC
Q
;
REN I '$D(FF) D HOME^%ZIS S FF=IOF
;
REN1 W @FF,!,"Reprint Lab/X-Ray Results for C&P Exams",!!!
S DIC="^DVB(396.3,",DIC(0)="AEQM" D ^DIC I X=""!(X=U) G KILL^DVBCUTIL
I +Y>0 S DA(1)=+Y,DFN=$P(Y,U,2)
W !! S %ZIS="AEQ",%ZIS("A")="Output device: " D ^%ZIS K %ZIS G:POP KILL^DVBCUTIL
I $D(IO("Q")) S ZTRTN="REN2^DVBCLABR",ZTIO=ION,ZTDESC="C&P lab/radiology print" F I="DIC*","DA*","DFN" S ZTSAVE(I)=""
I $D(IO("Q")) D ^%ZTLOAD W:$D(ZTSK) !!,"Request queued",!! H 2 G KILL^DVBCUTIL
REN2 U IO D SETLAB^DVBCPRNT,LAB S LKILL=1
Q:$G(DVBGUI) D:$D(ZTQUEUED) KILL^%ZTLOAD
G KILL^DVBCUTIL
;
RSET D:'$D(LRPARAM) DT^LRX,EN^LRPARAM S (LREND,LRSTOP)=0,LRCW=8,LRHF=1,LRFOOT=0,(LRONESPC,LRONETST)=""
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
Q
;
LK I DVBCW=1 S DVBCRLOC=$P(^LR(LRDFN,"CH",LRIDT,0),U,11)
I DVBCW=2 S DVBCRLOC=$P(^LR(LRDFN,"MI",LRIDT,0),U,8)
Q:DVBCRLOC="" ; * Quit if DVBCRLOC is NULL.
;
; ** NOTE: DVBCRALC=^Pointer to file 44^Pointer to file 44^
; ** NOTE: DVBCRALC pointers come from file 396.1 C&P ROUTING LOCATION
; ** DVBCRLOC is the REQUESTING LOCATION in the Lab Data File multiple
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
K DVBCXLOC
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCLABR 2290 printed Dec 13, 2024@01:44:37 Page 2
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
+2 ;
LAB NEW XX
SET XX=1
+1 FOR
if '$DATA(DVBCRALC(XX))
QUIT
Begin DoDot:1
+2 SET DVBCRALC=DVBCRALC(XX)
+3 SET XX=XX+1
DO LAB1
End DoDot:1
+4 QUIT
LAB1 ;print lab
+1 ;AJF;Request Status conversion
+2 SET STAT=$PIECE(^DVB(396.3,DA(1),0),U,18)
SET STAT=$$RSTAT^DVBCUTL8(STAT)
+3 ; ** Set variable DVBCRALC
if STAT["X"
QUIT
IF '$DATA(DVBCRALC)
DO SETLAB^DVBCPRNT
+4 SET LRDFN=$SELECT($DATA(^DPT(DFN,"LR")):+^("LR"),1:0)
SET DTREL=$PIECE(^DVB(396.3,DA(1),0),U,14)
if DTREL=""
QUIT
+5 ; ** 'CH' X-ref is for Chemistry tests, 'MI' X-ref is for Micro tests.
+6 DO RSET
SET DVBCW=1
FOR DVBCI=0:0
SET LRIDT=$ORDER(^LR(LRDFN,"CH",LRIDT))
if LRIDT=""!(LRIDT>LREDT)
QUIT
DO LK
+7 DO RSET
SET DVBCW=2
FOR DVBCI=0:0
SET LRIDT=$ORDER(^LR(LRDFN,"MI",LRIDT))
if LRIDT=""!(LRIDT>LREDT)
QUIT
DO LK
+8 ;
RAD ;print radiology
+1 ;quit if not running radiology package
if '$DATA(^RADPT(0))
QUIT
+2 SET RABDT=DVBCBDT
SET RAEDT=DTREL
SET RAHLOC=DVBCRALC
DO ^RAUTL3
+3 KILL DVBCW,RABDT,RAEDT,RAHLOC
+4 QUIT
+5 ;
REN IF '$DATA(FF)
DO HOME^%ZIS
SET FF=IOF
+1 ;
REN1 WRITE @FF,!,"Reprint Lab/X-Ray Results for C&P Exams",!!!
+1 SET DIC="^DVB(396.3,"
SET DIC(0)="AEQM"
DO ^DIC
IF X=""!(X=U)
GOTO KILL^DVBCUTIL
+2 IF +Y>0
SET DA(1)=+Y
SET DFN=$PIECE(Y,U,2)
+3 WRITE !!
SET %ZIS="AEQ"
SET %ZIS("A")="Output device: "
DO ^%ZIS
KILL %ZIS
if POP
GOTO KILL^DVBCUTIL
+4 IF $DATA(IO("Q"))
SET ZTRTN="REN2^DVBCLABR"
SET ZTIO=ION
SET ZTDESC="C&P lab/radiology print"
FOR I="DIC*","DA*","DFN"
SET ZTSAVE(I)=""
+5 IF $DATA(IO("Q"))
DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !!,"Request queued",!!
HANG 2
GOTO KILL^DVBCUTIL
REN2 USE IO
DO SETLAB^DVBCPRNT
DO LAB
SET LKILL=1
+1 if $GET(DVBGUI)
QUIT
if $DATA(ZTQUEUED)
DO KILL^%ZTLOAD
+2 GOTO KILL^DVBCUTIL
+3 ;
RSET if '$DATA(LRPARAM)
DO DT^LRX
DO EN^LRPARAM
SET (LREND,LRSTOP)=0
SET LRCW=8
SET LRHF=1
SET LRFOOT=0
SET (LRONESPC,LRONETST)=""
+1 SET LRLAB=1
SET X1=DTREL
SET X2=-120
DO C^%DTC
SET (DVBCBDT,LREDT)=X
SET LRSDT=DTREL
SET LRIDT=9999999-LRSDT
SET LREDT=9999999-LREDT
DO PT^LRX
+2 QUIT
+3 ;
LK IF DVBCW=1
SET DVBCRLOC=$PIECE(^LR(LRDFN,"CH",LRIDT,0),U,11)
+1 IF DVBCW=2
SET DVBCRLOC=$PIECE(^LR(LRDFN,"MI",LRIDT,0),U,8)
+2 ; * Quit if DVBCRLOC is NULL.
if DVBCRLOC=""
QUIT
+3 ;
+4 ; ** NOTE: DVBCRALC=^Pointer to file 44^Pointer to file 44^
+5 ; ** NOTE: DVBCRALC pointers come from file 396.1 C&P ROUTING LOCATION
+6 ; ** DVBCRLOC is the REQUESTING LOCATION in the Lab Data File multiple
+7 FOR ZJ=0:0
SET ZJ=$ORDER(^SC("C",DVBCRLOC,ZJ))
if ZJ=""
QUIT
SET DVBCXLOC=U_ZJ_U
IF DVBCRALC[DVBCXLOC
if DVBCW=1
DO CH^LRRP2
if DVBCW=2
DO MI^LRRP2
QUIT
+8 KILL DVBCXLOC
