LRCAPD2 ;DALISC/FHS - WORKLOAD CODE LIST REPORT ; 12/3/1997
;;5.2;LAB SERVICE;**153,201,351**;Sep 27, 1994
EN ;
W !!?5,"Produce a list of WKLD Code by Lab Section"
K DIR,ZTSAVE,DX
S DIR(0)="S^0:All;1:Billable Only",DIR("A")="Select WKLD CODE type to Print ",DIR("B")="Billable" D RDIR G:$G(LREND) CLEAN
S LRBIL=Y,ZTSAVE("LRBIL")=""
S DIR(0)="S^1:WORKLOAD LAB SECTION;2:LOCAL ACC AREA"
S DIR("A")="Sort WKLD CODES By " D RDIR G:$G(LREND) CLEAN
S LRSEC=Y,ZTSAVE("LRSEC")="" D
. I Y=2 D Q:$G(LREND) S LRAA=Y,ZTSAVE("LRAA")="" Q
. . S DIR(0)="P^68:QEZM",DIR("A")="Select Local Accession Area"
. . D RDIR
. I Y=1 D Q:$G(LREND) S LRSECT=Y,ZTSAVE("LRSECT")=""
. . S DIR(0)="P^64.21:QEZM",DIR("A")="Select WKLD CODE LAB SECTION "
. . D RDIR
G:$G(LREND) CLEAN
S DIR(0)="S^1:Actived Codes Only;0:All WKLD Codes"
S DIR("A")="Print Activated(reported) or All Codes" D RDIR
G:$G(LREND) CLEAN
S LRACT=Y,ZTSAVE("LRACT")=""
S DIR(0)="S^1:WKLD Name;2:NLT Code Number"
S DIR("A")="Print report sorted by "
D RDIR G:$G(LREND) CLEAN
S LRSORT=Y,ZTSAVE("LRSORT")=""
;Q
K %ZIS S %ZIS="QN",%ZIS("A")="Printer Name " D ^%ZIS G:POP CLEAN
I IO'=IO(0)!($D(IO("Q"))) D D ^%ZTLOAD,^%ZISC G CLEAN
.
. S ZTRTN="DQ^LRCAPD2",ZTIO=ION,ZTDESC="PRINT WKLD CODES FROM ^LAB(60 " W !!?10,"Report Queued to "_ION,!
G DQ
RDIR ;
S LREND=0 D ^DIR
S LREND=$S($D(DIRUT):1,$D(DUOUT):1,$D(DIRUT):1,$E(Y)="^":1,1:0)
K DIR
Q
DQ ;
I $D(ZTQUEUED) S ZTREQ="@" K LRDBUG
K ^TMP("LR",$J)
S (LRTS,LREND,LRPAG)=0,$P(LRLINE,"_",(IOM+1))=""
S LRPDT=$TR($$FMTE^XLFDT($$NOW^XLFDT,"1M"),"@"," ")
;test list
W:$E(IOST,1,2)="C-" @IOF
S LRTSN=0
SCR F S LRTSN=$O(^LAM(LRTSN)) Q:LRTSN<1 I $D(^(LRTSN,0))#2 S LRX=^(0) D
. I $G(LRBIL),'$P(LRX,U,5) Q
. I $G(LRSECT),$P(LRX,U,15)'=+LRSECT Q
. I $G(LRACT),'$P(LRX,U,17) Q
. I $G(LRAA),+$G(^(6))'=LRAA Q
. I LRSORT=1 S ^TMP("LR",$J,$P(LRX,U),$P(LRX,U,2))=LRTSN
. I LRSORT=2 S ^TMP("LR",$J,$P(LRX,U,2),$P(LRX,U))=LRTSN
PRT K DIR,DR,DA,DX,LREND,ZTSAVE
S LRGLB="",LRGLB=$O(^TMP("LR",$J,LRGLB)) I LRGLB="" D G CLEAN
. W !?10,"No WKLD CODES matched your Screening Criteria",!!
S LRHEAD0=LRPDT_" NLT Codes Listed by "_$S(LRSORT=1:"Name ",1:"Code Numbers ")_" Page "
S LRHEAD=" Sorted by " D
. I $G(LRBIL) S LRHEAD=LRHEAD_"Billable Codes "
. I $G(LRSECT) S LRHEAD=LRHEAD_"By { "_$P(^LAB(64.21,+LRSECT,0),U)_" } WKLD SECTION "
. I $G(LRACT) S LRHEAD2="Active NLT Codes Only "
. I '$G(LRACT) S LRHEAD2="Not sorted by Active Codes"
. I $G(LRAA) S LRHEAD3=$G(LRHEAD2)_"Accession Area "_$P(^LRO(68,+$G(LRAA),0),U)_" "
D HEAD S LRGLB="^TMP(""LR"","_$J_")",DIC="^LAM(",DR="0:99",S=1
F S LRGLB=$Q(@LRGLB) Q:$QS(LRGLB,1)'="LR"!($QS(LRGLB,2)'=$J)!($G(LREND)) D
. K DA S DA=@LRGLB
. I $Y>(IOSL-7) D PAUSE Q:$G(LREND)
. S S=$Y D EN^LRDIQ S:$D(DIRUT) LREND=1
G CLEAN
Q
HEAD ;
S LRPAG=$G(LRPAG)+1
W $$CJ^XLFSTR(LRHEAD0_LRPAG,IOM)
W $$CJ^XLFSTR(LRHEAD,IOM)
I $D(LRHEAD2) W $$CJ^XLFSTR(LRHEAD2,IOM)
I $D(LRHEAD3) W $$CJ^XLFSTR(LRHEAD3,IOM)
Q
PAUSE ;
I $E(IOST)="P" W @IOF D HEAD Q
Q:$E(IOST,1,2)'="C-"
K DIR,X,Y S DIR(0)="E" D RDIR Q:$G(LREND)
W @IOF D HEAD
Q
CLEAN I $D(ZTQUEUED) S ZTREQ="@"
Q:$G(LRDBUG)
W !! W:$E(IOST,1,2)="P-" @IOF
D ^%ZISC
K LRHEAD,LRHEAD2,LRHEAD3,LRPDT,LRSEC,LRSECT,LRSORT,LRAA,LRACT,LRBIL
K %ZIS,DA,DIC,DR,LRI,LRLINE,LRHED,LRI,LRJ,LRK,LRTS,LRTSN,LRX,NAME,NAME1
K %,LRCC,LREND,X,Y,ZTSK,DTOUT,DUOUT,DIRUT,LRPAG,DIR
K ^TMP("LR",$J),ZTSAVE,LRGLB,S,DX
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRCAPD2 3515 printed Sep 23, 2025@19:48:30 Page 2
LRCAPD2 ;DALISC/FHS - WORKLOAD CODE LIST REPORT ; 12/3/1997
+1 ;;5.2;LAB SERVICE;**153,201,351**;Sep 27, 1994
EN ;
+1 WRITE !!?5,"Produce a list of WKLD Code by Lab Section"
+2 KILL DIR,ZTSAVE,DX
+3 SET DIR(0)="S^0:All;1:Billable Only"
SET DIR("A")="Select WKLD CODE type to Print "
SET DIR("B")="Billable"
DO RDIR
if $GET(LREND)
GOTO CLEAN
+4 SET LRBIL=Y
SET ZTSAVE("LRBIL")=""
+5 SET DIR(0)="S^1:WORKLOAD LAB SECTION;2:LOCAL ACC AREA"
+6 SET DIR("A")="Sort WKLD CODES By "
DO RDIR
if $GET(LREND)
GOTO CLEAN
+7 SET LRSEC=Y
SET ZTSAVE("LRSEC")=""
Begin DoDot:1
+8 IF Y=2
Begin DoDot:2
+9 SET DIR(0)="P^68:QEZM"
SET DIR("A")="Select Local Accession Area"
+10 DO RDIR
End DoDot:2
if $GET(LREND)
QUIT
SET LRAA=Y
SET ZTSAVE("LRAA")=""
QUIT
+11 IF Y=1
Begin DoDot:2
+12 SET DIR(0)="P^64.21:QEZM"
SET DIR("A")="Select WKLD CODE LAB SECTION "
+13 DO RDIR
End DoDot:2
if $GET(LREND)
QUIT
SET LRSECT=Y
SET ZTSAVE("LRSECT")=""
End DoDot:1
+14 if $GET(LREND)
GOTO CLEAN
+15 SET DIR(0)="S^1:Actived Codes Only;0:All WKLD Codes"
+16 SET DIR("A")="Print Activated(reported) or All Codes"
DO RDIR
+17 if $GET(LREND)
GOTO CLEAN
+18 SET LRACT=Y
SET ZTSAVE("LRACT")=""
+19 SET DIR(0)="S^1:WKLD Name;2:NLT Code Number"
+20 SET DIR("A")="Print report sorted by "
+21 DO RDIR
if $GET(LREND)
GOTO CLEAN
+22 SET LRSORT=Y
SET ZTSAVE("LRSORT")=""
+23 ;Q
+24 KILL %ZIS
SET %ZIS="QN"
SET %ZIS("A")="Printer Name "
DO ^%ZIS
if POP
GOTO CLEAN
+25 IF IO'=IO(0)!($DATA(IO("Q")))
Begin DoDot:1
+26 +27 SET ZTRTN="DQ^LRCAPD2"
SET ZTIO=ION
SET ZTDESC="PRINT WKLD CODES FROM ^LAB(60 "
WRITE !!?10,"Report Queued to "_ION,!
End DoDot:1
DO ^%ZTLOAD
DO ^%ZISC
GOTO CLEAN
+28 GOTO DQ
RDIR ;
+1 SET LREND=0
DO ^DIR
+2 SET LREND=$SELECT($DATA(DIRUT):1,$DATA(DUOUT):1,$DATA(DIRUT):1,$EXTRACT(Y)="^":1,1:0)
+3 KILL DIR
+4 QUIT
DQ ;
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
KILL LRDBUG
+2 KILL ^TMP("LR",$JOB)
+3 SET (LRTS,LREND,LRPAG)=0
SET $PIECE(LRLINE,"_",(IOM+1))=""
+4 SET LRPDT=$TRANSLATE($$FMTE^XLFDT($$NOW^XLFDT,"1M"),"@"," ")
+5 ;test list
+6 if $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
+7 SET LRTSN=0
SCR FOR
SET LRTSN=$ORDER(^LAM(LRTSN))
if LRTSN<1
QUIT
IF $DATA(^(LRTSN,0))#2
SET LRX=^(0)
Begin DoDot:1
+1 IF $GET(LRBIL)
IF '$PIECE(LRX,U,5)
QUIT
+2 IF $GET(LRSECT)
IF $PIECE(LRX,U,15)'=+LRSECT
QUIT
+3 IF $GET(LRACT)
IF '$PIECE(LRX,U,17)
QUIT
+4 IF $GET(LRAA)
IF +$GET(^(6))'=LRAA
QUIT
+5 IF LRSORT=1
SET ^TMP("LR",$JOB,$PIECE(LRX,U),$PIECE(LRX,U,2))=LRTSN
+6 IF LRSORT=2
SET ^TMP("LR",$JOB,$PIECE(LRX,U,2),$PIECE(LRX,U))=LRTSN
End DoDot:1
PRT KILL DIR,DR,DA,DX,LREND,ZTSAVE
+1 SET LRGLB=""
SET LRGLB=$ORDER(^TMP("LR",$JOB,LRGLB))
IF LRGLB=""
Begin DoDot:1
+2 WRITE !?10,"No WKLD CODES matched your Screening Criteria",!!
End DoDot:1
GOTO CLEAN
+3 SET LRHEAD0=LRPDT_" NLT Codes Listed by "_$SELECT(LRSORT=1:"Name ",1:"Code Numbers ")_" Page "
+4 SET LRHEAD=" Sorted by "
Begin DoDot:1
+5 IF $GET(LRBIL)
SET LRHEAD=LRHEAD_"Billable Codes "
+6 IF $GET(LRSECT)
SET LRHEAD=LRHEAD_"By { "_$PIECE(^LAB(64.21,+LRSECT,0),U)_" } WKLD SECTION "
+7 IF $GET(LRACT)
SET LRHEAD2="Active NLT Codes Only "
+8 IF '$GET(LRACT)
SET LRHEAD2="Not sorted by Active Codes"
+9 IF $GET(LRAA)
SET LRHEAD3=$GET(LRHEAD2)_"Accession Area "_$PIECE(^LRO(68,+$GET(LRAA),0),U)_" "
End DoDot:1
+10 DO HEAD
SET LRGLB="^TMP(""LR"","_$JOB_")"
SET DIC="^LAM("
SET DR="0:99"
SET S=1
+11 FOR
SET LRGLB=$QUERY(@LRGLB)
if $QSUBSCRIPT(LRGLB,1)'="LR"!($QSUBSCRIPT(LRGLB,2)'=$JOB)!($GET(LREND))
QUIT
Begin DoDot:1
+12 KILL DA
SET DA=@LRGLB
+13 IF $Y>(IOSL-7)
DO PAUSE
if $GET(LREND)
QUIT
+14 SET S=$Y
DO EN^LRDIQ
if $DATA(DIRUT)
SET LREND=1
End DoDot:1
+15 GOTO CLEAN
+16 QUIT
HEAD ;
+1 SET LRPAG=$GET(LRPAG)+1
+2 WRITE $$CJ^XLFSTR(LRHEAD0_LRPAG,IOM)
+3 WRITE $$CJ^XLFSTR(LRHEAD,IOM)
+4 IF $DATA(LRHEAD2)
WRITE $$CJ^XLFSTR(LRHEAD2,IOM)
+5 IF $DATA(LRHEAD3)
WRITE $$CJ^XLFSTR(LRHEAD3,IOM)
+6 QUIT
PAUSE ;
+1 IF $EXTRACT(IOST)="P"
WRITE @IOF
DO HEAD
QUIT
+2 if $EXTRACT(IOST,1,2)'="C-"
QUIT
+3 KILL DIR,X,Y
SET DIR(0)="E"
DO RDIR
if $GET(LREND)
QUIT
+4 WRITE @IOF
DO HEAD
+5 QUIT
CLEAN IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+1 if $GET(LRDBUG)
QUIT
+2 WRITE !!
if $EXTRACT(IOST,1,2)="P-"
WRITE @IOF
+3 DO ^%ZISC
+4 KILL LRHEAD,LRHEAD2,LRHEAD3,LRPDT,LRSEC,LRSECT,LRSORT,LRAA,LRACT,LRBIL
+5 KILL %ZIS,DA,DIC,DR,LRI,LRLINE,LRHED,LRI,LRJ,LRK,LRTS,LRTSN,LRX,NAME,NAME1
+6 KILL %,LRCC,LREND,X,Y,ZTSK,DTOUT,DUOUT,DIRUT,LRPAG,DIR
+7 KILL ^TMP("LR",$JOB),ZTSAVE,LRGLB,S,DX
+8 QUIT
