- 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 Mar 13, 2025@20:57:30 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
