LRCAPD ;SLC/AM/DALOI/FHS - WORKLOAD CODE LIST REPORT;1/16/91 15:34
;;5.2;LAB SERVICE;**105,163,153,278**;Sep 27, 1994
EN ;
W !!?5,"I will produce a list of WKLD codes in your file 60 "
K %ZIS,DX S %ZIS="QN",%ZIS("A")="Printer Name " D ^%ZIS G:POP CLEAN
I IO'=IO(0)!($D(IO("Q"))) S ZTRTN="DQ^LRCAPD",ZTIO=ION,ZTDESC="PRINT WKLD CODES FROM ^LAB(60 " W !!?10,"Report Queued to "_ION,! D ^%ZTLOAD,^%ZISC G CLEAN
DQ ;
D START
D CLEAN
Q
START ;
K ^TMP("LR",$J,"CAP"),^TMP("LR",$J,"CAPN")
S (LRTS,LREND,LRPAG)=0,$P(LRLINE,"_",(IOM+1))=""
;test list
W:$E(IOST,1,2)="C-" @IOF
D HEAD
S LRTSN=""
F S LRTSN=$O(^LAB(60,"B",LRTSN)) Q:(LRTSN="")!($G(LREND)) D
.S LRTS=$O(^LAB(60,"B",LRTSN,0))
.I LRTS>0,'$G(^LAB(60,"B",LRTSN,LRTS)) D PRNT
Q:$G(LREND)
D PAUSE
;CAP code list
W @IOF
D HEAD2
S I=$O(^TMP("LR",$J,"CAP",0))
I '$L(I) W !!?5,"NONE",! S LREND=1
E D
.S DIC="^LAM(",(DR,LRI)=0
.F S LRI=$O(^TMP("LR",$J,"CAP",LRI)) Q:(LRI="")!($G(LREND)) S DA=^(LRI) D
..I $Y>(IOSL-8) D
...D PAUSE Q:$G(LREND)
...W @IOF
...D HEAD2
..Q:$G(LREND)
..S S=$Y D EN^DIQ
Q:$G(LREND)
NLTPRT W !! W:$E(IOST,12)="P-" @IOF I $O(^TMP("LR",$J,"CAPN",0))'="" D
. D HEAD3
. S DIC="^LAM(",(DR,LRI)=0
. F S LRI=$O(^TMP("LR",$J,"CAPN",LRI)) Q:(LRI="")!($G(LREND)) S DA=^(LRI) D
.. I $Y>(IOSL-8) D Q:$G(LREND)
... D PAUSE Q:$G(LREND)
... W @IOF
... D HEAD3
.. Q:$G(LREND)
.. S S=$Y D EN^DIQ
Q:$G(LREND)
D PAUSE
Q
PRNT ;
Q:$G(LREND)
I $Y>(IOSL-8) D Q:$G(LREND)
. D PAUSE Q:$G(LREND)
. W @IOF D HEAD
I '($D(^LAB(60,LRTS,0))#2) Q
S (NAME1,NAME)=""
I $G(^LAB(60,LRTS,64)) S LRCC=+^(64) D
. D NAME W ?5,"National VA Lab Code: ",$P($G(^LAM(+LRCC,0)),U,2)_" "_$P(^(0),U),!
. I $O(^LAM(+LRCC,4,0)) W ?15 D W !
. . S N=0 F S N=$O(^LAM(+LRCC,4,"B",N)) Q:N=""!($G(LREND)) W "[ CPT ",N," ] "
. G ERR:'$D(^LAM(LRCC,0)) S ^TMP("LR",$J,"CAPN",$P(^(0),U))=LRCC
I $P($G(^LAB(60,LRTS,64)),U,2) S LRCC=$P(^(64),U,2) D
. D NAME W ?5,"Result NLT Code: ",$P($G(^LAM(+LRCC,0)),U,2)_" "_$P(^(0),U),!
. G ERR:'$D(^LAM(LRCC,0)) S ^TMP("LR",$J,"CAPN",$P(^(0),U))=LRCC
S LRJ=0,LRJ=$O(^LAB(60,LRTS,9,LRJ)) I LRJ>0 D Q:$G(LREND)
.D NAME W ?15,"Verify",! D
..D:$D(^LAB(60,LRTS,9,LRJ,0))#2 PCC
..F LRK=0:0 S LRJ=$O(^LAB(60,LRTS,9,LRJ)) Q:(LRJ<1)!($G(LREND)) D:$D(^LAB(60,LRTS,9,LRJ,0))#2 PCC
Q:$G(LREND)
S LRJ=+$O(^LAB(60,LRTS,9.1,0))
Q:'LRJ
D NAME W ?15,"Accession",! D Q:$G(LREND)
.D:$D(^LAB(60,LRTS,9.1,LRJ,0))#2 PCC2
.F LRK=0:0 S LRJ=$O(^LAB(60,LRTS,9.1,LRJ)) Q:LRJ<1!($G(LREND)) D:$D(^LAB(60,LRTS,9.1,LRJ,0))#2 PCC2
Q:$G(LREND)
S LRJ=+$O(^LAB(60,LRTS,3,1,9,0))
Q:'LRJ
D NAME W ?15,"Sample",! D
.D:$D(^LAB(60,LRTS,3,1,9,LRJ,0))#2 PCC3
.F LRK=0:0 S LRJ=$O(^LAB(60,LRTS,3,1,9,LRJ)) Q:(LRJ<1)!($G(LREND)) D:$D(^LAB(60,LRTS,3,1,9,LRJ,0))#2 PCC3
Q
PCC ;
Q:$G(LREND)
S LRX=^LAB(60,LRTS,9,LRJ,0),LRCC=+LRX G ERR:'$D(^LAM(LRCC,0)) S ^TMP("LR",$J,"CAP",$P(^(0),U))=LRCC
I $Y>(IOSL-6) D
.D PAUSE Q:$G(LREND)
.S NAME1=0 W @IOF D HEAD,NAME W ?15,"Verify",!
Q:$G(LREND)
W ?10,$S($D(^LAM(LRCC,0))#2:$S($P(^(0),U,5):"+"_$P(^(0),U),1:$P(^(0),U)),1:""),?50,$P(LRX,U,2),?73,$S($P(LRX,U,3):$P(LRX,U,3),1:"1"),!
Q
PCC2 ;
Q:$G(LREND)
S LRX=^LAB(60,LRTS,9.1,LRJ,0),LRCC=+LRX G ERR:'$D(^LAM(LRCC,0)) S ^TMP("LR",$J,"CAP",$P(^(0),U))=LRCC
I $Y>(IOSL-6) D
.D PAUSE Q:$G(LREND)
.S NAME1=0 W @IOF D HEAD,NAME W ?15,"Accession",!
Q:$G(LREND)
W ?10,$S($D(^LAM(LRCC,0))#2:$S($P(^(0),U,5):"+"_$P(^(0),U),1:$P(^(0),U)),1:""),?50,$P(LRX,U,2),?73,$S($P(LRX,U,3):$P(LRX,U,3),1:"1"),!
Q
PCC3 ;
Q:$G(LREND)
S LRX=^LAB(60,LRTS,3,1,9,LRJ,0),LRCC=+LRX G ERR:'$D(^LAM(LRCC,0)) S ^TMP("LR",$J,"CAP",$P(^(0),U))=LRCC
I $Y>(IOSL-6) D
.D PAUSE Q:$G(LREND)
.S NAME1=0 W @IOF D HEAD,NAME W ?15,"Sample",!
Q:$G(LREND)
W ?10,$S($D(^LAM(LRCC,0))#2:$S($P(^(0),U,5):"+"_$P(^(0),U),1:$P(^(0),U)),1:""),?50,$P(LRX,U,2),?73,$S($P(LRX,U,3):$P(LRX,U,3),1:"1"),!
Q
HEAD ;
Q:$G(LREND)
S LRPAG=$G(LRPAG)+1
W !!?21,"LIST OF FILE 60 WKLD CODES",?70,"Page ",$J(LRPAG,3),!
W !,"IEN",?15,"WKLD Code [TYPE] ",?50,"WKLD Number",?73,"X",!,LRLINE,!
Q
HEAD2 ;
Q:$G(LREND)
S LRPAG=$G(LRPAG)+1
W !!?10,"Alphabetical Listing of WKLD Codes Defined"
W ?72,"Page ",$J(LRPAG,3),!
Q
HEAD3 ;
Q:$G(LREND)
S LRPAG=$G(LRPAG)+1
W !!?10,"Alphabetical Listing of NLT or Result NLT Codes Defined"
W ?72,"Page ",$J(LRPAG,3),!
Q
NAME ;
S LRTY=$P(^LAB(60,LRTS,0),U,3) W:'$G(NAME1) !,LRTS,?6,$P(^LAB(60,LRTS,0),U),"[ "_$S(LRTY="I":"INPUT",LRTY="O":"OUTPUT",LRTY="B":"BOTH",1:"NEITHER")_" ]",!
S NAME1=1
Q
ERR W !?10,$C(7)," Error in WKLD Code pointer (",$G(LRCC),") ***** ",!
Q
PAUSE ;
Q:$G(LREND)
Q:$E(IOST,1,2)'="C-"
K DIR,X,Y S DIR(0)="E" D ^DIR
S:($D(DTOUT))!($D(DUOUT)) LREND=1
Q
CLEAN I $D(ZTQUEUED) S ZTREQ="@"
W !! W:$E(IOST,1,2)="P-" @IOF
D ^%ZISC
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,DX,S
K ^TMP("LR",$J,"CAP"),^TMP("LR",$J,"CAPN")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRCAPD 5065 printed Nov 22, 2024@17:22:54 Page 2
LRCAPD ;SLC/AM/DALOI/FHS - WORKLOAD CODE LIST REPORT;1/16/91 15:34
+1 ;;5.2;LAB SERVICE;**105,163,153,278**;Sep 27, 1994
EN ;
+1 WRITE !!?5,"I will produce a list of WKLD codes in your file 60 "
+2 KILL %ZIS,DX
SET %ZIS="QN"
SET %ZIS("A")="Printer Name "
DO ^%ZIS
if POP
GOTO CLEAN
+3 IF IO'=IO(0)!($DATA(IO("Q")))
SET ZTRTN="DQ^LRCAPD"
SET ZTIO=ION
SET ZTDESC="PRINT WKLD CODES FROM ^LAB(60 "
WRITE !!?10,"Report Queued to "_ION,!
DO ^%ZTLOAD
DO ^%ZISC
GOTO CLEAN
DQ ;
+1 DO START
+2 DO CLEAN
+3 QUIT
START ;
+1 KILL ^TMP("LR",$JOB,"CAP"),^TMP("LR",$JOB,"CAPN")
+2 SET (LRTS,LREND,LRPAG)=0
SET $PIECE(LRLINE,"_",(IOM+1))=""
+3 ;test list
+4 if $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
+5 DO HEAD
+6 SET LRTSN=""
+7 FOR
SET LRTSN=$ORDER(^LAB(60,"B",LRTSN))
if (LRTSN="")!($GET(LREND))
QUIT
Begin DoDot:1
+8 SET LRTS=$ORDER(^LAB(60,"B",LRTSN,0))
+9 IF LRTS>0
IF '$GET(^LAB(60,"B",LRTSN,LRTS))
DO PRNT
End DoDot:1
+10 if $GET(LREND)
QUIT
+11 DO PAUSE
+12 ;CAP code list
+13 WRITE @IOF
+14 DO HEAD2
+15 SET I=$ORDER(^TMP("LR",$JOB,"CAP",0))
+16 IF '$LENGTH(I)
WRITE !!?5,"NONE",!
SET LREND=1
+17 IF '$TEST
Begin DoDot:1
+18 SET DIC="^LAM("
SET (DR,LRI)=0
+19 FOR
SET LRI=$ORDER(^TMP("LR",$JOB,"CAP",LRI))
if (LRI="")!($GET(LREND))
QUIT
SET DA=^(LRI)
Begin DoDot:2
+20 IF $Y>(IOSL-8)
Begin DoDot:3
+21 DO PAUSE
if $GET(LREND)
QUIT
+22 WRITE @IOF
+23 DO HEAD2
End DoDot:3
+24 if $GET(LREND)
QUIT
+25 SET S=$Y
DO EN^DIQ
End DoDot:2
End DoDot:1
+26 if $GET(LREND)
QUIT
NLTPRT WRITE !!
if $EXTRACT(IOST,12)="P-"
WRITE @IOF
IF $ORDER(^TMP("LR",$JOB,"CAPN",0))'=""
Begin DoDot:1
+1 DO HEAD3
+2 SET DIC="^LAM("
SET (DR,LRI)=0
+3 FOR
SET LRI=$ORDER(^TMP("LR",$JOB,"CAPN",LRI))
if (LRI="")!($GET(LREND))
QUIT
SET DA=^(LRI)
Begin DoDot:2
+4 IF $Y>(IOSL-8)
Begin DoDot:3
+5 DO PAUSE
if $GET(LREND)
QUIT
+6 WRITE @IOF
+7 DO HEAD3
End DoDot:3
if $GET(LREND)
QUIT
+8 if $GET(LREND)
QUIT
+9 SET S=$Y
DO EN^DIQ
End DoDot:2
End DoDot:1
+10 if $GET(LREND)
QUIT
+11 DO PAUSE
+12 QUIT
PRNT ;
+1 if $GET(LREND)
QUIT
+2 IF $Y>(IOSL-8)
Begin DoDot:1
+3 DO PAUSE
if $GET(LREND)
QUIT
+4 WRITE @IOF
DO HEAD
End DoDot:1
if $GET(LREND)
QUIT
+5 IF '($DATA(^LAB(60,LRTS,0))#2)
QUIT
+6 SET (NAME1,NAME)=""
+7 IF $GET(^LAB(60,LRTS,64))
SET LRCC=+^(64)
Begin DoDot:1
+8 DO NAME
WRITE ?5,"National VA Lab Code: ",$PIECE($GET(^LAM(+LRCC,0)),U,2)_" "_$PIECE(^(0),U),!
+9 IF $ORDER(^LAM(+LRCC,4,0))
WRITE ?15
Begin DoDot:2
+10 SET N=0
FOR
SET N=$ORDER(^LAM(+LRCC,4,"B",N))
if N=""!($GET(LREND))
QUIT
WRITE "[ CPT ",N," ] "
End DoDot:2
WRITE !
+11 if '$DATA(^LAM(LRCC,0))
GOTO ERR
SET ^TMP("LR",$JOB,"CAPN",$PIECE(^(0),U))=LRCC
End DoDot:1
+12 IF $PIECE($GET(^LAB(60,LRTS,64)),U,2)
SET LRCC=$PIECE(^(64),U,2)
Begin DoDot:1
+13 DO NAME
WRITE ?5,"Result NLT Code: ",$PIECE($GET(^LAM(+LRCC,0)),U,2)_" "_$PIECE(^(0),U),!
+14 if '$DATA(^LAM(LRCC,0))
GOTO ERR
SET ^TMP("LR",$JOB,"CAPN",$PIECE(^(0),U))=LRCC
End DoDot:1
+15 SET LRJ=0
SET LRJ=$ORDER(^LAB(60,LRTS,9,LRJ))
IF LRJ>0
Begin DoDot:1
+16 DO NAME
WRITE ?15,"Verify",!
Begin DoDot:2
+17 if $DATA(^LAB(60,LRTS,9,LRJ,0))#2
DO PCC
+18 FOR LRK=0:0
SET LRJ=$ORDER(^LAB(60,LRTS,9,LRJ))
if (LRJ<1)!($GET(LREND))
QUIT
if $DATA(^LAB(60,LRTS,9,LRJ,0))#2
DO PCC
End DoDot:2
End DoDot:1
if $GET(LREND)
QUIT
+19 if $GET(LREND)
QUIT
+20 SET LRJ=+$ORDER(^LAB(60,LRTS,9.1,0))
+21 if 'LRJ
QUIT
+22 DO NAME
WRITE ?15,"Accession",!
Begin DoDot:1
+23 if $DATA(^LAB(60,LRTS,9.1,LRJ,0))#2
DO PCC2
+24 FOR LRK=0:0
SET LRJ=$ORDER(^LAB(60,LRTS,9.1,LRJ))
if LRJ<1!($GET(LREND))
QUIT
if $DATA(^LAB(60,LRTS,9.1,LRJ,0))#2
DO PCC2
End DoDot:1
if $GET(LREND)
QUIT
+25 if $GET(LREND)
QUIT
+26 SET LRJ=+$ORDER(^LAB(60,LRTS,3,1,9,0))
+27 if 'LRJ
QUIT
+28 DO NAME
WRITE ?15,"Sample",!
Begin DoDot:1
+29 if $DATA(^LAB(60,LRTS,3,1,9,LRJ,0))#2
DO PCC3
+30 FOR LRK=0:0
SET LRJ=$ORDER(^LAB(60,LRTS,3,1,9,LRJ))
if (LRJ<1)!($GET(LREND))
QUIT
if $DATA(^LAB(60,LRTS,3,1,9,LRJ,0))#2
DO PCC3
End DoDot:1
+31 QUIT
PCC ;
+1 if $GET(LREND)
QUIT
+2 SET LRX=^LAB(60,LRTS,9,LRJ,0)
SET LRCC=+LRX
if '$DATA(^LAM(LRCC,0))
GOTO ERR
SET ^TMP("LR",$JOB,"CAP",$PIECE(^(0),U))=LRCC
+3 IF $Y>(IOSL-6)
Begin DoDot:1
+4 DO PAUSE
if $GET(LREND)
QUIT
+5 SET NAME1=0
WRITE @IOF
DO HEAD
DO NAME
WRITE ?15,"Verify",!
End DoDot:1
+6 if $GET(LREND)
QUIT
+7 WRITE ?10,$SELECT($DATA(^LAM(LRCC,0))#2:$SELECT($PIECE(^(0),U,5):"+"_$PIECE(^(0),U),1:$PIECE(^(0),U)),1:""),?50,$PIECE(LRX,U,2),?73,$SELECT($PIECE(LRX,U,3):$PIECE(LRX,U,3),1:"1"),!
+8 QUIT
PCC2 ;
+1 if $GET(LREND)
QUIT
+2 SET LRX=^LAB(60,LRTS,9.1,LRJ,0)
SET LRCC=+LRX
if '$DATA(^LAM(LRCC,0))
GOTO ERR
SET ^TMP("LR",$JOB,"CAP",$PIECE(^(0),U))=LRCC
+3 IF $Y>(IOSL-6)
Begin DoDot:1
+4 DO PAUSE
if $GET(LREND)
QUIT
+5 SET NAME1=0
WRITE @IOF
DO HEAD
DO NAME
WRITE ?15,"Accession",!
End DoDot:1
+6 if $GET(LREND)
QUIT
+7 WRITE ?10,$SELECT($DATA(^LAM(LRCC,0))#2:$SELECT($PIECE(^(0),U,5):"+"_$PIECE(^(0),U),1:$PIECE(^(0),U)),1:""),?50,$PIECE(LRX,U,2),?73,$SELECT($PIECE(LRX,U,3):$PIECE(LRX,U,3),1:"1"),!
+8 QUIT
PCC3 ;
+1 if $GET(LREND)
QUIT
+2 SET LRX=^LAB(60,LRTS,3,1,9,LRJ,0)
SET LRCC=+LRX
if '$DATA(^LAM(LRCC,0))
GOTO ERR
SET ^TMP("LR",$JOB,"CAP",$PIECE(^(0),U))=LRCC
+3 IF $Y>(IOSL-6)
Begin DoDot:1
+4 DO PAUSE
if $GET(LREND)
QUIT
+5 SET NAME1=0
WRITE @IOF
DO HEAD
DO NAME
WRITE ?15,"Sample",!
End DoDot:1
+6 if $GET(LREND)
QUIT
+7 WRITE ?10,$SELECT($DATA(^LAM(LRCC,0))#2:$SELECT($PIECE(^(0),U,5):"+"_$PIECE(^(0),U),1:$PIECE(^(0),U)),1:""),?50,$PIECE(LRX,U,2),?73,$SELECT($PIECE(LRX,U,3):$PIECE(LRX,U,3),1:"1"),!
+8 QUIT
HEAD ;
+1 if $GET(LREND)
QUIT
+2 SET LRPAG=$GET(LRPAG)+1
+3 WRITE !!?21,"LIST OF FILE 60 WKLD CODES",?70,"Page ",$JUSTIFY(LRPAG,3),!
+4 WRITE !,"IEN",?15,"WKLD Code [TYPE] ",?50,"WKLD Number",?73,"X",!,LRLINE,!
+5 QUIT
HEAD2 ;
+1 if $GET(LREND)
QUIT
+2 SET LRPAG=$GET(LRPAG)+1
+3 WRITE !!?10,"Alphabetical Listing of WKLD Codes Defined"
+4 WRITE ?72,"Page ",$JUSTIFY(LRPAG,3),!
+5 QUIT
HEAD3 ;
+1 if $GET(LREND)
QUIT
+2 SET LRPAG=$GET(LRPAG)+1
+3 WRITE !!?10,"Alphabetical Listing of NLT or Result NLT Codes Defined"
+4 WRITE ?72,"Page ",$JUSTIFY(LRPAG,3),!
+5 QUIT
NAME ;
+1 SET LRTY=$PIECE(^LAB(60,LRTS,0),U,3)
if '$GET(NAME1)
WRITE !,LRTS,?6,$PIECE(^LAB(60,LRTS,0),U),"[ "_$SELECT(LRTY="I":"INPUT",LRTY="O":"OUTPUT",LRTY="B":"BOTH",1:"NEITHER")_" ]",!
+2 SET NAME1=1
+3 QUIT
ERR WRITE !?10,$CHAR(7)," Error in WKLD Code pointer (",$GET(LRCC),") ***** ",!
+1 QUIT
PAUSE ;
+1 if $GET(LREND)
QUIT
+2 if $EXTRACT(IOST,1,2)'="C-"
QUIT
+3 KILL DIR,X,Y
SET DIR(0)="E"
DO ^DIR
+4 if ($DATA(DTOUT))!($DATA(DUOUT))
SET LREND=1
+5 QUIT
CLEAN IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+1 WRITE !!
if $EXTRACT(IOST,1,2)="P-"
WRITE @IOF
+2 DO ^%ZISC
+3 KILL %ZIS,DA,DIC,DR,LRI,LRLINE,LRHED,LRI,LRJ,LRK,LRTS,LRTSN,LRX,NAME,NAME1
+4 KILL %,LRCC,LREND,X,Y,ZTSK,DTOUT,DUOUT,DIRUT,LRPAG,DIR,DX,S
+5 KILL ^TMP("LR",$JOB,"CAP"),^TMP("LR",$JOB,"CAPN")
+6 QUIT
