- LRCAPD2 ;VA/DALISC/FHS - WORKLOAD CODE LIST REPORT ;JUL 06, 2010 3:14 PM
- ;;5.2;LAB SERVICE;**153,201,351,1027**;NOV 01, 1997
- 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
- LRCAPD2 ;VA/DALISC/FHS - WORKLOAD CODE LIST REPORT ;JUL 06, 2010 3:14 PM
- +1 ;;5.2;LAB SERVICE;**153,201,351,1027**;NOV 01, 1997
- 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 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
- +27 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
