- 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 Jan 18, 2025@03:20:39 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