ECXLABPI ;BIR/DMA-One Time Routine to Print Lab Tests ; 08 Aug 94 / 6:50 AM
;;3.0;DSS EXTRACTS;**8**;Dec 22, 1997
W !!,"This will print a list of your lab products from the Lab extract file"
S %ZIS="Q" D ^%ZIS K %ZIS Q:POP
I $D(IO("Q")) S ZTDESC="Lab product list",ZTRTN="EN^ECXLABPI" D ^%ZTLOAD,^%ZISC K ZTRTN,ZTDESC Q
;
EN ;
K ^TMP($J)
F J=0:0 S J=$O(^ECX(727.813,J)) Q:'J S EC=$G(^(J,0)) I EC]"" S ABR=$P(EC,U,11),TES=$P(EC,U,12),TEN=$P($G(^LAB(60,+TES,0)),U),^TMP($J,ABR,TES)=TEN
;
D HEAD S ABR="" F S ABR=$O(^TMP($J,ABR)) Q:ABR="" F J=0:0 S J=$O(^TMP($J,ABR,J)) Q:'J W !,?7,ABR,?15,J,?25,^(J) I $Y+4>IOSL D HEAD
D ^%ZISC S ZTREQ="@" K ^TMP($J) Q
;
HEAD W:$Y @IOF W !,?20,"LAB EXTRACT PRODUCTS",!,"ACCESSION",?12,"NUMBER",?30,"DESCRIPTION",!!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXLABPI 780 printed Dec 13, 2024@01:52:50 Page 2
ECXLABPI ;BIR/DMA-One Time Routine to Print Lab Tests ; 08 Aug 94 / 6:50 AM
+1 ;;3.0;DSS EXTRACTS;**8**;Dec 22, 1997
+2 WRITE !!,"This will print a list of your lab products from the Lab extract file"
+3 SET %ZIS="Q"
DO ^%ZIS
KILL %ZIS
if POP
QUIT
+4 IF $DATA(IO("Q"))
SET ZTDESC="Lab product list"
SET ZTRTN="EN^ECXLABPI"
DO ^%ZTLOAD
DO ^%ZISC
KILL ZTRTN,ZTDESC
QUIT
+5 ;
EN ;
+1 KILL ^TMP($JOB)
+2 FOR J=0:0
SET J=$ORDER(^ECX(727.813,J))
if 'J
QUIT
SET EC=$GET(^(J,0))
IF EC]""
SET ABR=$PIECE(EC,U,11)
SET TES=$PIECE(EC,U,12)
SET TEN=$PIECE($GET(^LAB(60,+TES,0)),U)
SET ^TMP($JOB,ABR,TES)=TEN
+3 ;
+4 DO HEAD
SET ABR=""
FOR
SET ABR=$ORDER(^TMP($JOB,ABR))
if ABR=""
QUIT
FOR J=0:0
SET J=$ORDER(^TMP($JOB,ABR,J))
if 'J
QUIT
WRITE !,?7,ABR,?15,J,?25,^(J)
IF $Y+4>IOSL
DO HEAD
+5 DO ^%ZISC
SET ZTREQ="@"
KILL ^TMP($JOB)
QUIT
+6 ;
HEAD if $Y
WRITE @IOF
WRITE !,?20,"LAB EXTRACT PRODUCTS",!,"ACCESSION",?12,"NUMBER",?30,"DESCRIPTION",!!
+1 QUIT
