- LRCAPD ;SLC/AM/DALOI/FHS - WORKLOAD CODE LIST REPORT;1/16/91 15:34
- ;;5.2T9;LR;**105,163,153,278,1018**;Nov 17, 2004
- 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
- LRCAPD ;SLC/AM/DALOI/FHS - WORKLOAD CODE LIST REPORT;1/16/91 15:34
- +1 ;;5.2T9;LR;**105,163,153,278,1018**;Nov 17, 2004
- 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
