LRRP6 ;DALISC/J0 - LAB TEST/WORKLOAD CODE REPORTS ;12/07/92
;;5.2;LAB SERVICE;**201**;Sep 27, 1994
EN ;
S LREND=0
D SELECT
D:'LREND DEVICE
D:'LREND @ZTRTN
D WRAPUP
Q
SELECT ;
D SITE Q:LREND
D DIV Q:LREND
D DATES Q:LREND
D METHOD Q:LREND
D ACCAREA Q:LREND
I ZTRTN="DQ^LRRP6A1" D SETACCN Q:LREND
D REPTYP Q:LREND
Q
SITE ;
S LRSITNUM=+$P($G(^XMB(1,1,"XUS")),U,17)
I 'LRSITNUM W !!,"NO SITE DEFINED -- CAN'T REPORT" S LREND=1 Q
S LRSITE=$P($G(^DIC(4,LRSITNUM,0)),U) S:LRSITE="" LRSITE="UNKNOWN"
Q
DIV ;
S %=2 W !,"Do you want to print a specific DIVISION (YES or NO)"
D YN^DICN
I %=-1 S LREND=1 Q
I %=1 D
. S DIC("A")="Select a Division:",DIC=4,DIC(0)="AEMQ"
. F D ^DIC Q:Y=-1 D
. . S LRDIVSEL=+Y
. . S LRDIVSEL(+Y)=$S($L($P($G(^DIC(4,+Y,0)),U)):$P(^(0),U),1:"ERROR"_Y)
I ($D(DTOUT)#2)!(($D(DUOUT)#2)&('$D(LRDIVSEL))) S LREND=1 Q
Q
DATES ;
S %DT="AEX",%DT("A")="BEGIN DATE : "
D ^%DT I (X=U)!(X="") S LREND=1 Q
S LRSDT=Y
S LRSDAT=$$Y2K^LRX(Y)
S %DT="AEX",%DT("A")="END DATE : "
D ^%DT I (X=U)!(X="") S LREND=1 Q
S LREDT=Y
S LREDAT=$$Y2K^LRX(Y)
I LREDT<LRSDT S X=LREDT,LREDT=LRSDT,LRSDT=X
S LRSDT=LRSDT-.000001
S LRDATRNG=LRSDAT_" to "_LREDAT
Q
METHOD ;
K DIR S DIR("A",1)="TEST AUDIT should not be used for workload reporting."
S DIR("A",2)="It should ONLY be used for trouble Shooting.",DIR("A",3)=" "
S DIR(0)="SM^T:TEST AUDIT (File 68);W:WORKLOAD CODE (File 64.1)",DIR("A")="REPORT BY"
D ^DIR I ($D(DUOUT))!($D(DTOUT)) S LREND=1 Q
S ZTRTN=$S(Y="T":"DQ^LRRP6A1",Y="W":"DQ^LRRP6B1")
K DIR
Q
ACCAREA ;
K DIC S DIC=68,DIC(0)="AEMQZ"
S DIC("A")="Select ACCESSION AREA (required - 1 only): "
D ^DIC
I Y=-1 S LREND=1 Q
S LRX=$P(Y,U,2),LRAA=+Y
S ACCTRNS=$P(^LRO(68,LRAA,0),U,3)
Q
SETACCN ;
;S LRANL=+$P(^LRO(68,LRAA,1,LRDT,1,0),U,4)
K DIR
S DIR(0)="NO^1:999999"
S DIR("A")="Start with accession #",DIR("B")=1
D ^DIR I $D(DUOUT)!($D(DTOUT)) S LREND=1 Q
S:X>0 LRANF=X-1
S:ACCTRNS="Y" LRDT=$E(LRSDT,1,3)_"0000"
S:ACCTRNS'="Y" LRDT=$E(LRSDT,1,3)_"00"
;S LAST=$P(^LRO(68,LRAA,1,LRDT,1,0),U,4)
K DIR
S DIR(0)="NO^1:999999"
S DIR("A")="End with accession #",DIR("B")=999999
D ^DIR I $D(DUOUT)!($D(DTOUT)) S LREND=1 Q
S LRANL=+X
Q
REPTYP ;
K DIR S DIR(0)="SM^D:DETAILED;C:CONDENSED",DIR("A")="REPORT TYPE"
D ^DIR I $D(DUOUT)!($D(DTOUT)) S LREND=1 Q
S LRREPTYP=Y
K DIR
Q
DEVICE ;
K IOP,IO("Q") S POP=0,%ZIS="QP" D ^%ZIS
I POP S LREND=1 Q
I $D(IO("Q")) D QUE S LREND=1 Q
Q
WRAPUP ;
W:'LREND !!,?23,"*** END OF REPORT ***"
D:($E(IOST,1,2)="C-")&('LREND) PAUSE
W !! W:$E(IOST,1,2)="P-" @IOF D:'$D(ZTQUEUED) ^%ZISC
S:$D(ZTQUEUED) ZTREQ="@"
K ^TMP("LR",$J)
K DTOUT,DUOUT,DIRUT,DIROUT,X,Y,%,%ZIS,DIC,%Y,%DT,I,POP,DIR
K ZTIO,ZTRTN,ZTSAVE,ZTDESC,ZTSK,LRAA,LRANN,LRSUM,LRTMULT
K LREND,LRPAG,LRDT,LRDAT,LRSDT,LREDT,LRSDAT,LREDAT,LRDATRNG,LRX,LRNODE
K LRTIC,LRANF,LRANL
K LRDIV,LRDIVNAM,LRDIVSEL,LRFIRST,LRREPTYP,LRTN,LRTST,LRTSTREC,LRTNAM
K LRSITNUM,LRSITE,LRCC,LRAN,LRCPN,LRDASH,LRSTAR,LRSUBH,LRV657,LRV658
D WKLDCLN^LRCAPU
Q
QUE ;
K IO("Q") I '$D(ZTIO),$D(ION),ION="" S ZTIO=""
S ZTDESC="LRRP6_ - TEST/WKLD/VENIPUNCTURE REP"
S ZTSAVE("LR*")="" D ^%ZTLOAD
Q
PAUSE ;
K DIR S DIR(0)="E" D ^DIR
S:($D(DTOUT))!($D(DUOUT)) LREND=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRRP6 3318 printed Dec 13, 2024@02:19:57 Page 2
LRRP6 ;DALISC/J0 - LAB TEST/WORKLOAD CODE REPORTS ;12/07/92
+1 ;;5.2;LAB SERVICE;**201**;Sep 27, 1994
EN ;
+1 SET LREND=0
+2 DO SELECT
+3 if 'LREND
DO DEVICE
+4 if 'LREND
DO @ZTRTN
+5 DO WRAPUP
+6 QUIT
SELECT ;
+1 DO SITE
if LREND
QUIT
+2 DO DIV
if LREND
QUIT
+3 DO DATES
if LREND
QUIT
+4 DO METHOD
if LREND
QUIT
+5 DO ACCAREA
if LREND
QUIT
+6 IF ZTRTN="DQ^LRRP6A1"
DO SETACCN
if LREND
QUIT
+7 DO REPTYP
if LREND
QUIT
+8 QUIT
SITE ;
+1 SET LRSITNUM=+$PIECE($GET(^XMB(1,1,"XUS")),U,17)
+2 IF 'LRSITNUM
WRITE !!,"NO SITE DEFINED -- CAN'T REPORT"
SET LREND=1
QUIT
+3 SET LRSITE=$PIECE($GET(^DIC(4,LRSITNUM,0)),U)
if LRSITE=""
SET LRSITE="UNKNOWN"
+4 QUIT
DIV ;
+1 SET %=2
WRITE !,"Do you want to print a specific DIVISION (YES or NO)"
+2 DO YN^DICN
+3 IF %=-1
SET LREND=1
QUIT
+4 IF %=1
Begin DoDot:1
+5 SET DIC("A")="Select a Division:"
SET DIC=4
SET DIC(0)="AEMQ"
+6 FOR
DO ^DIC
if Y=-1
QUIT
Begin DoDot:2
+7 SET LRDIVSEL=+Y
+8 SET LRDIVSEL(+Y)=$SELECT($LENGTH($PIECE($GET(^DIC(4,+Y,0)),U)):$PIECE(^(0),U),1:"ERROR"_Y)
End DoDot:2
End DoDot:1
+9 IF ($DATA(DTOUT)#2)!(($DATA(DUOUT)#2)&('$DATA(LRDIVSEL)))
SET LREND=1
QUIT
+10 QUIT
DATES ;
+1 SET %DT="AEX"
SET %DT("A")="BEGIN DATE : "
+2 DO ^%DT
IF (X=U)!(X="")
SET LREND=1
QUIT
+3 SET LRSDT=Y
+4 SET LRSDAT=$$Y2K^LRX(Y)
+5 SET %DT="AEX"
SET %DT("A")="END DATE : "
+6 DO ^%DT
IF (X=U)!(X="")
SET LREND=1
QUIT
+7 SET LREDT=Y
+8 SET LREDAT=$$Y2K^LRX(Y)
+9 IF LREDT<LRSDT
SET X=LREDT
SET LREDT=LRSDT
SET LRSDT=X
+10 SET LRSDT=LRSDT-.000001
+11 SET LRDATRNG=LRSDAT_" to "_LREDAT
+12 QUIT
METHOD ;
+1 KILL DIR
SET DIR("A",1)="TEST AUDIT should not be used for workload reporting."
+2 SET DIR("A",2)="It should ONLY be used for trouble Shooting."
SET DIR("A",3)=" "
+3 SET DIR(0)="SM^T:TEST AUDIT (File 68);W:WORKLOAD CODE (File 64.1)"
SET DIR("A")="REPORT BY"
+4 DO ^DIR
IF ($DATA(DUOUT))!($DATA(DTOUT))
SET LREND=1
QUIT
+5 SET ZTRTN=$SELECT(Y="T":"DQ^LRRP6A1",Y="W":"DQ^LRRP6B1")
+6 KILL DIR
+7 QUIT
ACCAREA ;
+1 KILL DIC
SET DIC=68
SET DIC(0)="AEMQZ"
+2 SET DIC("A")="Select ACCESSION AREA (required - 1 only): "
+3 DO ^DIC
+4 IF Y=-1
SET LREND=1
QUIT
+5 SET LRX=$PIECE(Y,U,2)
SET LRAA=+Y
+6 SET ACCTRNS=$PIECE(^LRO(68,LRAA,0),U,3)
+7 QUIT
SETACCN ;
+1 ;S LRANL=+$P(^LRO(68,LRAA,1,LRDT,1,0),U,4)
+2 KILL DIR
+3 SET DIR(0)="NO^1:999999"
+4 SET DIR("A")="Start with accession #"
SET DIR("B")=1
+5 DO ^DIR
IF $DATA(DUOUT)!($DATA(DTOUT))
SET LREND=1
QUIT
+6 if X>0
SET LRANF=X-1
+7 if ACCTRNS="Y"
SET LRDT=$EXTRACT(LRSDT,1,3)_"0000"
+8 if ACCTRNS'="Y"
SET LRDT=$EXTRACT(LRSDT,1,3)_"00"
+9 ;S LAST=$P(^LRO(68,LRAA,1,LRDT,1,0),U,4)
+10 KILL DIR
+11 SET DIR(0)="NO^1:999999"
+12 SET DIR("A")="End with accession #"
SET DIR("B")=999999
+13 DO ^DIR
IF $DATA(DUOUT)!($DATA(DTOUT))
SET LREND=1
QUIT
+14 SET LRANL=+X
+15 QUIT
REPTYP ;
+1 KILL DIR
SET DIR(0)="SM^D:DETAILED;C:CONDENSED"
SET DIR("A")="REPORT TYPE"
+2 DO ^DIR
IF $DATA(DUOUT)!($DATA(DTOUT))
SET LREND=1
QUIT
+3 SET LRREPTYP=Y
+4 KILL DIR
+5 QUIT
DEVICE ;
+1 KILL IOP,IO("Q")
SET POP=0
SET %ZIS="QP"
DO ^%ZIS
+2 IF POP
SET LREND=1
QUIT
+3 IF $DATA(IO("Q"))
DO QUE
SET LREND=1
QUIT
+4 QUIT
WRAPUP ;
+1 if 'LREND
WRITE !!,?23,"*** END OF REPORT ***"
+2 if ($EXTRACT(IOST,1,2)="C-")&('LREND)
DO PAUSE
+3 WRITE !!
if $EXTRACT(IOST,1,2)="P-"
WRITE @IOF
if '$DATA(ZTQUEUED)
DO ^%ZISC
+4 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+5 KILL ^TMP("LR",$JOB)
+6 KILL DTOUT,DUOUT,DIRUT,DIROUT,X,Y,%,%ZIS,DIC,%Y,%DT,I,POP,DIR
+7 KILL ZTIO,ZTRTN,ZTSAVE,ZTDESC,ZTSK,LRAA,LRANN,LRSUM,LRTMULT
+8 KILL LREND,LRPAG,LRDT,LRDAT,LRSDT,LREDT,LRSDAT,LREDAT,LRDATRNG,LRX,LRNODE
+9 KILL LRTIC,LRANF,LRANL
+10 KILL LRDIV,LRDIVNAM,LRDIVSEL,LRFIRST,LRREPTYP,LRTN,LRTST,LRTSTREC,LRTNAM
+11 KILL LRSITNUM,LRSITE,LRCC,LRAN,LRCPN,LRDASH,LRSTAR,LRSUBH,LRV657,LRV658
+12 DO WKLDCLN^LRCAPU
+13 QUIT
QUE ;
+1 KILL IO("Q")
IF '$DATA(ZTIO)
IF $DATA(ION)
IF ION=""
SET ZTIO=""
+2 SET ZTDESC="LRRP6_ - TEST/WKLD/VENIPUNCTURE REP"
+3 SET ZTSAVE("LR*")=""
DO ^%ZTLOAD
+4 QUIT
PAUSE ;
+1 KILL DIR
SET DIR(0)="E"
DO ^DIR
+2 if ($DATA(DTOUT))!($DATA(DUOUT))
SET LREND=1
+3 QUIT
