source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRAPD.m@ 700

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

initial load of WorldVistAEHR

File size: 1.3 KB
RevLine 
[613]1LRAPD ;AVAMC/REG/WTY - AP DATA ENTRY ;11/27/01
2 ;;5.2;LAB SERVICE;**72,91,259**;Sep 27, 1994
3MAIN ;
4 S:'$D(LRSOP) LRSOP=""
5 I LRCAPA D G:'$D(X) END
6 .D @(LRSS_"^LRAPSWK")
7 S LRD(1)=LRD,LRD=LRD_LRSS_"^LRAPD1",LR("TR")=""
8 D @LRD
9 I LRD(1)="P" D Q
10 .D AK^LRAPDA,END
11 D ^LRAPDA
12 D END
13 Q
14A ;also from LRAPOLD,LRAPM,LRAPQAMR,LRAPQAT
15 S LRDICS="SPCYEM" D ^LRAP Q:'$D(Y)
16 S LRV=$P($G(^LRO(69.2,LRAA,0)),U,10)
17 S X=$G(^LAB(69.9,1,11))
18 S LR("FS")=+X
19 S LR("DX")=$S(LRSS="SP":$P(X,U,2),LRSS="CY":$P(X,U,3),1:"")
20 S:LR("DX")="" LR("DX")=$S(LRSS="EM":$P(X,U,4),1:0)
21 Q
22R ;
23 S Y=$S('X:0,'$D(^LAB(61.5,X,0)):0,'$P(^LAB(61.5,X,0),U,3):0,1:.02)
24 Q
25T ;
26 S LR(8)=$S('X:0,'$D(^LAB(61,X,0)):0,1:$P(^LAB(61,X,0),U,4))
27 Q
28EN ;Gross Description/Clinical HX
29 D A
30 I '$D(Y) D END Q
31 S LRD=""
32 D MAIN
33 Q
34EN1 ;Gross Review/Micro Description
35 D A
36 I '$D(Y) D END Q
37 S LRD="M"
38 D MAIN
39 Q
40EN2 ;Micro Description/SNOMED Coding
41 D A
42 I '$D(Y) D END Q
43 S LRD="B"
44 D MAIN
45 Q
46EN3 ;Micro Description/ICD9CM Coding
47 D A
48 I '$D(Y) D END Q
49 I '$O(^ICD0(0)) D Q
50 .W $C(7),!!,"No entries in the ICD DIAGNOSIS File (#80)."
51 S LRD="A"
52 D MAIN
53 Q
54EN4 ;Supplementary Report
55 D A
56 I '$D(Y) D END Q
57 S LRD="S"
58 D MAIN
59 Q
60EN5 ;Special Studies
61 D A
62 I '$D(Y) D END Q
63 S LRD="P"
64 D MAIN
65 Q
66END ;Clean-up
67 K DR,LRSFLG,LRREL
68 D V^LRU
69 Q
Note: See TracBrowser for help on using the repository browser.