source: FOIAVistA/tag/r/LAB_SERVICE-LR-LS/LRCAPD.m

Last change on this file was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 4.8 KB
Line 
1LRCAPD ;SLC/AM/DALOI/FHS - WORKLOAD CODE LIST REPORT;1/16/91 15:34
2 ;;5.2;LAB SERVICE;**105,163,153,278**;Sep 27, 1994
3EN ;
4 W !!?5,"I will produce a list of WKLD codes in your file 60 "
5 K %ZIS,DX S %ZIS="QN",%ZIS("A")="Printer Name " D ^%ZIS G:POP CLEAN
6 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
7DQ ;
8 D START
9 D CLEAN
10 Q
11START ;
12 K ^TMP("LR",$J,"CAP"),^TMP("LR",$J,"CAPN")
13 S (LRTS,LREND,LRPAG)=0,$P(LRLINE,"_",(IOM+1))=""
14 ;test list
15 W:$E(IOST,1,2)="C-" @IOF
16 D HEAD
17 S LRTSN=""
18 F S LRTSN=$O(^LAB(60,"B",LRTSN)) Q:(LRTSN="")!($G(LREND)) D
19 .S LRTS=$O(^LAB(60,"B",LRTSN,0))
20 .I LRTS>0,'$G(^LAB(60,"B",LRTSN,LRTS)) D PRNT
21 Q:$G(LREND)
22 D PAUSE
23 ;CAP code list
24 W @IOF
25 D HEAD2
26 S I=$O(^TMP("LR",$J,"CAP",0))
27 I '$L(I) W !!?5,"NONE",! S LREND=1
28 E D
29 .S DIC="^LAM(",(DR,LRI)=0
30 .F S LRI=$O(^TMP("LR",$J,"CAP",LRI)) Q:(LRI="")!($G(LREND)) S DA=^(LRI) D
31 ..I $Y>(IOSL-8) D
32 ...D PAUSE Q:$G(LREND)
33 ...W @IOF
34 ...D HEAD2
35 ..Q:$G(LREND)
36 ..S S=$Y D EN^DIQ
37 Q:$G(LREND)
38NLTPRT W !! W:$E(IOST,12)="P-" @IOF I $O(^TMP("LR",$J,"CAPN",0))'="" D
39 . D HEAD3
40 . S DIC="^LAM(",(DR,LRI)=0
41 . F S LRI=$O(^TMP("LR",$J,"CAPN",LRI)) Q:(LRI="")!($G(LREND)) S DA=^(LRI) D
42 .. I $Y>(IOSL-8) D Q:$G(LREND)
43 ... D PAUSE Q:$G(LREND)
44 ... W @IOF
45 ... D HEAD3
46 .. Q:$G(LREND)
47 .. S S=$Y D EN^DIQ
48 Q:$G(LREND)
49 D PAUSE
50 Q
51PRNT ;
52 Q:$G(LREND)
53 I $Y>(IOSL-8) D Q:$G(LREND)
54 . D PAUSE Q:$G(LREND)
55 . W @IOF D HEAD
56 I '($D(^LAB(60,LRTS,0))#2) Q
57 S (NAME1,NAME)=""
58 I $G(^LAB(60,LRTS,64)) S LRCC=+^(64) D
59 . D NAME W ?5,"National VA Lab Code: ",$P($G(^LAM(+LRCC,0)),U,2)_" "_$P(^(0),U),!
60 . I $O(^LAM(+LRCC,4,0)) W ?15 D W !
61 . . S N=0 F S N=$O(^LAM(+LRCC,4,"B",N)) Q:N=""!($G(LREND)) W "[ CPT ",N," ] "
62 . G ERR:'$D(^LAM(LRCC,0)) S ^TMP("LR",$J,"CAPN",$P(^(0),U))=LRCC
63 I $P($G(^LAB(60,LRTS,64)),U,2) S LRCC=$P(^(64),U,2) D
64 . D NAME W ?5,"Result NLT Code: ",$P($G(^LAM(+LRCC,0)),U,2)_" "_$P(^(0),U),!
65 . G ERR:'$D(^LAM(LRCC,0)) S ^TMP("LR",$J,"CAPN",$P(^(0),U))=LRCC
66 S LRJ=0,LRJ=$O(^LAB(60,LRTS,9,LRJ)) I LRJ>0 D Q:$G(LREND)
67 .D NAME W ?15,"Verify",! D
68 ..D:$D(^LAB(60,LRTS,9,LRJ,0))#2 PCC
69 ..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
70 Q:$G(LREND)
71 S LRJ=+$O(^LAB(60,LRTS,9.1,0))
72 Q:'LRJ
73 D NAME W ?15,"Accession",! D Q:$G(LREND)
74 .D:$D(^LAB(60,LRTS,9.1,LRJ,0))#2 PCC2
75 .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
76 Q:$G(LREND)
77 S LRJ=+$O(^LAB(60,LRTS,3,1,9,0))
78 Q:'LRJ
79 D NAME W ?15,"Sample",! D
80 .D:$D(^LAB(60,LRTS,3,1,9,LRJ,0))#2 PCC3
81 .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
82 Q
83PCC ;
84 Q:$G(LREND)
85 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
86 I $Y>(IOSL-6) D
87 .D PAUSE Q:$G(LREND)
88 .S NAME1=0 W @IOF D HEAD,NAME W ?15,"Verify",!
89 Q:$G(LREND)
90 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"),!
91 Q
92PCC2 ;
93 Q:$G(LREND)
94 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
95 I $Y>(IOSL-6) D
96 .D PAUSE Q:$G(LREND)
97 .S NAME1=0 W @IOF D HEAD,NAME W ?15,"Accession",!
98 Q:$G(LREND)
99 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"),!
100 Q
101PCC3 ;
102 Q:$G(LREND)
103 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
104 I $Y>(IOSL-6) D
105 .D PAUSE Q:$G(LREND)
106 .S NAME1=0 W @IOF D HEAD,NAME W ?15,"Sample",!
107 Q:$G(LREND)
108 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"),!
109 Q
110HEAD ;
111 Q:$G(LREND)
112 S LRPAG=$G(LRPAG)+1
113 W !!?21,"LIST OF FILE 60 WKLD CODES",?70,"Page ",$J(LRPAG,3),!
114 W !,"IEN",?15,"WKLD Code [TYPE] ",?50,"WKLD Number",?73,"X",!,LRLINE,!
115 Q
116HEAD2 ;
117 Q:$G(LREND)
118 S LRPAG=$G(LRPAG)+1
119 W !!?10,"Alphabetical Listing of WKLD Codes Defined"
120 W ?72,"Page ",$J(LRPAG,3),!
121 Q
122HEAD3 ;
123 Q:$G(LREND)
124 S LRPAG=$G(LRPAG)+1
125 W !!?10,"Alphabetical Listing of NLT or Result NLT Codes Defined"
126 W ?72,"Page ",$J(LRPAG,3),!
127 Q
128NAME ;
129 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")_" ]",!
130 S NAME1=1
131 Q
132ERR W !?10,$C(7)," Error in WKLD Code pointer (",$G(LRCC),") ***** ",!
133 Q
134PAUSE ;
135 Q:$G(LREND)
136 Q:$E(IOST,1,2)'="C-"
137 K DIR,X,Y S DIR(0)="E" D ^DIR
138 S:($D(DTOUT))!($D(DUOUT)) LREND=1
139 Q
140CLEAN I $D(ZTQUEUED) S ZTREQ="@"
141 W !! W:$E(IOST,1,2)="P-" @IOF
142 D ^%ZISC
143 K %ZIS,DA,DIC,DR,LRI,LRLINE,LRHED,LRI,LRJ,LRK,LRTS,LRTSN,LRX,NAME,NAME1
144 K %,LRCC,LREND,X,Y,ZTSK,DTOUT,DUOUT,DIRUT,LRPAG,DIR,DX,S
145 K ^TMP("LR",$J,"CAP"),^TMP("LR",$J,"CAPN")
146 Q
Note: See TracBrowser for help on using the repository browser.