source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRBEPRPT.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: 5.7 KB
Line 
1LRBEPRPT ;DALOI/FHS - PRINT CPT CODES FOR TESTS AND PANELS ;03/30/2005
2 ;;5.2;LAB SERVICE;**291,359**;Sep 27, 1994
3BEBA ;Individual test CPT code look-up
4 K ^TMP("LR",$J,"VTO"),^TMP("LR",$J,"TMP")
5 S (LRBEPSY,LRBECPT)="" K DIR,X,Y,LRSTOP,LRPG
6 S LRBECDT=DT
7 S DIR(0)="PO^60:AQEZNM"
8 S DIR("S")="I $S('$L($P(^(0),U,3)):0,$P(^(0),U,3)=""N"":0,1:1)"
9 D ^DIR K DIR
10 I $G(Y)<1 D CLEAN Q
11 W @IOF
12 S LRBELOP=1,LRBEBY=Y,LRPRT=0
13 D LOOP
14 I $G(OUT) D Q
15 . W !,+LRBEBY_" = "_$P(^LAB(60,+LRBEBY,0),U)
16 . W !,"********** ","Invalid data prevents display.",!
17 D:'$G(OUT) T1
18 D CLEAN
19 G BEBA
20LOOP ;
21 Q:$G(LRBEPSY)!($G(LRSTOP))
22 S:'$G(LRSPEC) LRSPEC=99999999 S:'$G(LRBECDT) LRBECDT=DT
23 K DIC,LRTEST,LRNAME,LRNLT,T1,LRY,LRBECPT,LRORD
24 K LRM,LRMX
25 K ^TMP("LR",$J,"VTO"),^TMP("LR",$J,"TMP")
26 S LRBECPT=""
27 S X=+LRBEBY_U_+LRBEBY,LRNLT=+LRBEBY,LRTEST(1,"P")=LRNLT_U_$$NLT^LRVER1(LRNLT)
28 S T1=1,LRTEST(T1)=+LRBEBY_U_^LAB(60,+LRBEBY,0)
29 S OUT=0,XX=$P(LRTEST(T1),U,6) D Q:OUT
30 . I XX'="",+$P(XX,";",2)=0 S OUT=1 Q
31 . I XX'="" S LRBEY(+LRBEBY,+$P(XX,";",2))=""
32 . I $D(^LAB(60,+LRBEBY,2)) D
33 . . S I=0 F S I=$O(^LAB(60,+LRBEBY,2,I)) Q:'I D
34 . . . S K=$P(^LAB(60,+LRBEBY,2,I,0),U,1)
35 . . . S XX=$P(^LAB(60,K,0),U,5) I XX'="",+$P(XX,";",2)=0 S OUT=1 Q
36 . . . S LRBEY(+LRBEBY,+$P(XX,";",2))=""
37 K LRBECPT
38 S LRBETST=0,(LRPANEL,LRBEPYS)=""
39 S LRBETST=$O(LRBEY(LRBETST)) Q:LRBETST<1!($G(LRSTOP)) D
40 . Q:'$G(^LAB(60,LRBETST,12))
41 . Q:$L($P(^LAB(60,LRBETST,0),U,5))
42 . D PANEL^LRBEBA4
43 . I '$O(LRBECPT(LRBETST,0)) Q
44 . S LRPANEL="*"
45 . S LRBEPSY=1 D DISPLAY
46 . S (LRPANEL)=""
47 . W !
48PANEL ;Display panel test CPT
49 I $G(LRBEPSY) K LRBECPT Q
50 I $O(LRBECPT(0)) D Q:$G(LRBELOP)!($G(LRSTOP))
51 . S LRBEPYS=1 D DISPLAY
52 Q:$S($G(LRBEPO):1,$G(LRBEPYS):1,1:0)
53 K LRBECPT
54 S LRTST=0,LRBETST=+LRBEBY
55NLT ;
56 S LRBECDT=DT D PANEL^LRBEBA4
57 Q:'$O(LRBECPT(0))
58 S LRI=0 F S LRI=$O(LRBECPT(LRBETST,LRI)) Q:LRI<1!($G(LRSTOP)) D
59 . D LN Q:$G(LRSTOP)
60 . ;W !,"{"_LRBETST_"="_$P(^LAB(60,LRBETST,0),U)_"} "_$P($G(LRBEBY),U,2)
61 . ;W:$D(^LAB(61,LRSPEC,0))#2 " (SPEC) = "_$E($P(^(0),U),1,30)
62 . S LRREQ=$S($P($G(^LAB(60,LRBETST,0)),U,17):"r ",1:" ")
63 . W !,LRBETST_" = "_LRREQ_$P($G(LRBEBY),U,2)_" " ;_$P(^LAB(60,LRBETST,0),U)
64 . W:$D(^LAB(61,LRSPEC,0))#2 " (SPEC) = "_$E($P(^(0),U),1,30)
65 . D WRT
66 Q
67 ;
68DISPLAY ;
69 Q:$G(LRSTOP) K LRREQ
70 I $O(LRBECPT(0)),'$G(LRPRT) W ! S LRPRT=1
71 S LRBETST=0 F S LRBETST=$O(LRBECPT(LRBETST)) Q:LRBETST<1!($G(LRSTOP)) D
72 . D LN Q:$G(LRSTOP)
73 . S LRREQ=$S($P($G(^LAB(60,LRBETST,0)),U,17):"r ",1:"")
74 . W !,LRBETST_" = "_LRREQ_$P(^LAB(60,LRBETST,0),U) I $D(^LAB(61,LRSPEC,0))#2 W " / "_$P(^(0),U)
75 . S LRI=0 F S LRI=$O(LRBECPT(LRBETST,LRI)) Q:LRI<1 D WRT
76 Q
77WRT ;
78 D LN Q:$G(LRSTOP)
79 S LRPRT=1
80 S LRCPT=$O(LRBECPT(LRBETST,LRI,0)) Q:'LRCPT!($G(LRSTOP)) D
81 . D LN Q:$G(LRSTOP)
82 . S XCODE=$$CPT^ICPTCOD(LRCPT)
83 . W !?6,$P(XCODE,U,2)_" "_$P(XCODE,U,3)_" ["_LRBECPT(LRBETST,LRI,LRCPT)_"]"_$G(LRPANEL)
84 . K LRBECPT(LRBETST,LRI,LRCPT),XCODE
85 Q
86 ;
87LN ;Check line spacing
88 Q:$Y<(IOSL-4)!($G(LRSTOP))
89 I $E(IOST,1)="C" D Q:LRSTOP
90 . N DIR S DIR(0)="E" D ^DIR S LRSTOP=$G(DIRUT)
91HDR ;Report header
92 W @IOF,! S LRPG=$G(LRPG)+1
93 W $$CJ^XLFSTR($G(LRHDR)_" "_$$FMTE^XLFDT(DT,5)_" Pg "_LRPG,IOM),!
94 Q
95 ;
96TEST ;List all test with CPT codes
97 ;logic follows the Billing Aware CPT logic Hierarchy
98 U IO
99 I '$G(LRPG) D HDR
100 S LRBELOP=1,LRBECDT=DT
101 S LRTN="^LAB(60,""B"")"
102 F Q:$G(LRSTOP) S LRTN=$Q(@LRTN) Q:$QS(LRTN,2)'="B" D
103 . Q:$G(@LRTN)
104 . S LRSPEC=999999,LRBEBY=$QS(LRTN,4)
105 . Q:$S('$D(^LAB(60,LRBEBY,0))#2:1,'$L($P(^(0),U,3)):1,$P(^(0),U,3)="N":1,1:0)
106 . Q:$G(LRSTOP)
107 . S LRPRT=0,LRBEPSY=""
108 . S LRBEBY=LRBEBY_U_$P(^LAB(60,+LRBEBY,0),U)
109 . D LOOP
110 . Q:$G(OUT)
111 . Q:$G(LRSTOP)
112 . D T1
113 . K LRBEY,LRBEBY
114 . Q:$G(LRSTOP)
115 D CLEAN
116 Q
117 ;
118T1 ;
119 S LRSPEC=0 F S LRSPEC=$O(^LAB(60,+LRBEBY,1,LRSPEC)) Q:LRSPEC<1!($G(LRSTOP)) D
120 . D LOOP
121 . K LRBECPT
122 Q:$G(OUT)
123 Q:$G(LRSTOP)
124 D ATOMIC
125 I $G(LRPRT) W !
126 K LRBEPSY
127 Q
128 ;
129ATOMIC ; Print Atomic test of panel
130 Q:'$O(^LAB(60,+LRBEBY,2,0))
131 W !,+LRBEBY_" = "_$P(^LAB(60,+LRBEBY,0),U),!,"**********"
132 N LRBEBSY,LRII,LRREQ
133 S LRBEBSY=+LRBEBY N LRII S LRII=0
134 F S LRII=$O(^LAB(60,LRBEBSY,2,LRII)) Q:LRII<1!($G(LRSTOP)) D
135 . S LRBEBY=+$G(^LAB(60,LRBEBSY,2,LRII,0)) Q:'LRBEBY!($G(LRSTOP)) D
136 . . S LRREQ=$S($P($G(^LAB(60,LRBEBY,0)),U,17):"r",1:" ")
137 . . I $D(^LAB(60,LRBEBY,0)) S LRBEBY=LRREQ_"["_LRBEBY_"] "_$P(^(0),U) D
138 . . . W ?15,LRBEBY,! D LN
139 Q
140 ;
141ASK ;Present user with a selection of options
142 K DIR,Y,LRSTOP,POP,ZTRTN,OUT,OPT,XX
143 K LRDEV,ZTDTH,ZTDESC,ZTIO,ZTSAVE
144 S OUT=0
145 S LRBECDT=DT
146 S DIR(0)="SO^1:Single Test Look-up;2:List Panels Only;3:List All Test"
147 D ^DIR K DIR
148 I Y<1 G CLEAN
149 S OPT=Y
150 I OPT=1 D G ASK
151 . S LRHDR="*** Single Test code listing (CPT) ***"
152 . D BEBA
153 I OPT=2 D G ASK
154 . S LRHDR="*** Panel Tests Only (CPT) ***",LRBEPO=1
155 . D DEV I $G(POP) D ^%ZISC Q
156 . I IO'=IO(0) D Q
157 . . S ZTSAVE("LRBEPO")=""
158 . . S ZTRTN="TEST^LRBEPRPT"
159 . . D LOAD
160 . D TEST
161 I OPT=3 D G ASK
162 . D DEV I $G(POP) D ^%ZISC Q
163 . S LRHDR="*** All Lab Tests (CPT) ***"
164 . I IO'=IO(0) D Q
165 . . S ZTRTN="TEST^LRBEPRPT"
166 . . D LOAD
167 . D TEST
168 Q
169 ;
170DEV ;Select print device
171 N %ZIS,LRMSG,ZTDESC,ZTDTH,ZTIO,ZTSK,ZTSAVE
172 S %ZIS="NQ",%ZIS("A")=" Select Print Device: "
173 S (LRDEV,%ZIS("B"))="Home" D ^%ZIS
174 Q
175LOAD ;%ZTLOAD section
176 S ZTDTH=$H
177 S ZTDESC=$G(LRHDR)
178 S (LRDEV,ZTIO)=ION,ZTSAVE("LRHDR")=""
179 D ^%ZTLOAD W @IOF,!,$S($G(ZTSK):"Queued to device "_LRDEV,1:"Not Queued"),!
180 D ^%ZISC
181 D HOME^%ZIS
182 Q
183 ;
184CLEAN ;Clean-up
185 W:$D(ZTQUEUED) @IOF
186 K DIC,DIR,DIRUT,DTOUT,DUOUT
187 K LRBEBY,LRBECPT,LRBECDT,LRBEDT,LRBELOP,LRBEPYS,LRBEYS,LRBENLT,LRBETST,LRBEY,LRCFL
188 K LRCPT,LRI,LRIEN,LRM,LRMX,LRNAME,LRNLT,LRNX,LRORD,LRBEPO,LRPANEL,LRPRT
189 K LRSPEC,LRSTOP,LRSUB,LRTEST,LRTN,LRTST,LRXX,LRY,S2,T1,X,Y,YY
190 K LRHDR,LRDEV,LRPG,POP
191 K ^TMP("LR",$J,"VTO"),^TMP("LR",$J,"TMP")
192 D ^%ZISC
193 Q
Note: See TracBrowser for help on using the repository browser.