source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRCAPD2.m@ 1006

Last change on this file since 1006 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.3 KB
Line 
1LRCAPD2 ;DALISC/FHS - WORKLOAD CODE LIST REPORT ; 12/3/1997
2 ;;5.2;LAB SERVICE;**153,201,351**;Sep 27, 1994
3EN ;
4 W !!?5,"Produce a list of WKLD Code by Lab Section"
5 K DIR,ZTSAVE,DX
6 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
7 S LRBIL=Y,ZTSAVE("LRBIL")=""
8 S DIR(0)="S^1:WORKLOAD LAB SECTION;2:LOCAL ACC AREA"
9 S DIR("A")="Sort WKLD CODES By " D RDIR G:$G(LREND) CLEAN
10 S LRSEC=Y,ZTSAVE("LRSEC")="" D
11 . I Y=2 D Q:$G(LREND) S LRAA=Y,ZTSAVE("LRAA")="" Q
12 . . S DIR(0)="P^68:QEZM",DIR("A")="Select Local Accession Area"
13 . . D RDIR
14 . I Y=1 D Q:$G(LREND) S LRSECT=Y,ZTSAVE("LRSECT")=""
15 . . S DIR(0)="P^64.21:QEZM",DIR("A")="Select WKLD CODE LAB SECTION "
16 . . D RDIR
17 G:$G(LREND) CLEAN
18 S DIR(0)="S^1:Actived Codes Only;0:All WKLD Codes"
19 S DIR("A")="Print Activated(reported) or All Codes" D RDIR
20 G:$G(LREND) CLEAN
21 S LRACT=Y,ZTSAVE("LRACT")=""
22 S DIR(0)="S^1:WKLD Name;2:NLT Code Number"
23 S DIR("A")="Print report sorted by "
24 D RDIR G:$G(LREND) CLEAN
25 S LRSORT=Y,ZTSAVE("LRSORT")=""
26 ;Q
27 K %ZIS S %ZIS="QN",%ZIS("A")="Printer Name " D ^%ZIS G:POP CLEAN
28 I IO'=IO(0)!($D(IO("Q"))) D D ^%ZTLOAD,^%ZISC G CLEAN
29 .
30 . S ZTRTN="DQ^LRCAPD2",ZTIO=ION,ZTDESC="PRINT WKLD CODES FROM ^LAB(60 " W !!?10,"Report Queued to "_ION,!
31 G DQ
32RDIR ;
33 S LREND=0 D ^DIR
34 S LREND=$S($D(DIRUT):1,$D(DUOUT):1,$D(DIRUT):1,$E(Y)="^":1,1:0)
35 K DIR
36 Q
37DQ ;
38 I $D(ZTQUEUED) S ZTREQ="@" K LRDBUG
39 K ^TMP("LR",$J)
40 S (LRTS,LREND,LRPAG)=0,$P(LRLINE,"_",(IOM+1))=""
41 S LRPDT=$TR($$FMTE^XLFDT($$NOW^XLFDT,"1M"),"@"," ")
42 ;test list
43 W:$E(IOST,1,2)="C-" @IOF
44 S LRTSN=0
45SCR F S LRTSN=$O(^LAM(LRTSN)) Q:LRTSN<1 I $D(^(LRTSN,0))#2 S LRX=^(0) D
46 . I $G(LRBIL),'$P(LRX,U,5) Q
47 . I $G(LRSECT),$P(LRX,U,15)'=+LRSECT Q
48 . I $G(LRACT),'$P(LRX,U,17) Q
49 . I $G(LRAA),+$G(^(6))'=LRAA Q
50 . I LRSORT=1 S ^TMP("LR",$J,$P(LRX,U),$P(LRX,U,2))=LRTSN
51 . I LRSORT=2 S ^TMP("LR",$J,$P(LRX,U,2),$P(LRX,U))=LRTSN
52PRT K DIR,DR,DA,DX,LREND,ZTSAVE
53 S LRGLB="",LRGLB=$O(^TMP("LR",$J,LRGLB)) I LRGLB="" D G CLEAN
54 . W !?10,"No WKLD CODES matched your Screening Criteria",!!
55 S LRHEAD0=LRPDT_" NLT Codes Listed by "_$S(LRSORT=1:"Name ",1:"Code Numbers ")_" Page "
56 S LRHEAD=" Sorted by " D
57 . I $G(LRBIL) S LRHEAD=LRHEAD_"Billable Codes "
58 . I $G(LRSECT) S LRHEAD=LRHEAD_"By { "_$P(^LAB(64.21,+LRSECT,0),U)_" } WKLD SECTION "
59 . I $G(LRACT) S LRHEAD2="Active NLT Codes Only "
60 . I '$G(LRACT) S LRHEAD2="Not sorted by Active Codes"
61 . I $G(LRAA) S LRHEAD3=$G(LRHEAD2)_"Accession Area "_$P(^LRO(68,+$G(LRAA),0),U)_" "
62 D HEAD S LRGLB="^TMP(""LR"","_$J_")",DIC="^LAM(",DR="0:99",S=1
63 F S LRGLB=$Q(@LRGLB) Q:$QS(LRGLB,1)'="LR"!($QS(LRGLB,2)'=$J)!($G(LREND)) D
64 . K DA S DA=@LRGLB
65 . I $Y>(IOSL-7) D PAUSE Q:$G(LREND)
66 . S S=$Y D EN^LRDIQ S:$D(DIRUT) LREND=1
67 G CLEAN
68 Q
69HEAD ;
70 S LRPAG=$G(LRPAG)+1
71 W $$CJ^XLFSTR(LRHEAD0_LRPAG,IOM)
72 W $$CJ^XLFSTR(LRHEAD,IOM)
73 I $D(LRHEAD2) W $$CJ^XLFSTR(LRHEAD2,IOM)
74 I $D(LRHEAD3) W $$CJ^XLFSTR(LRHEAD3,IOM)
75 Q
76PAUSE ;
77 I $E(IOST)="P" W @IOF D HEAD Q
78 Q:$E(IOST,1,2)'="C-"
79 K DIR,X,Y S DIR(0)="E" D RDIR Q:$G(LREND)
80 W @IOF D HEAD
81 Q
82CLEAN I $D(ZTQUEUED) S ZTREQ="@"
83 Q:$G(LRDBUG)
84 W !! W:$E(IOST,1,2)="P-" @IOF
85 D ^%ZISC
86 K LRHEAD,LRHEAD2,LRHEAD3,LRPDT,LRSEC,LRSECT,LRSORT,LRAA,LRACT,LRBIL
87 K %ZIS,DA,DIC,DR,LRI,LRLINE,LRHED,LRI,LRJ,LRK,LRTS,LRTSN,LRX,NAME,NAME1
88 K %,LRCC,LREND,X,Y,ZTSK,DTOUT,DUOUT,DIRUT,LRPAG,DIR
89 K ^TMP("LR",$J),ZTSAVE,LRGLB,S,DX
90 Q
Note: See TracBrowser for help on using the repository browser.