source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRSPRPT1.m@ 1259

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

initial load of WorldVistAEHR

File size: 2.9 KB
Line 
1LRSPRPT1 ;AVAMC/REG/WTY - SURG PATH RPT PRINT CONT. ;10/16/01
2 ;;5.2;LAB SERVICE;**1,259**;Sep 27, 1994
3 ;
4 ;25-Jul-01;WTY;In line tag L, if being called by LRAPT2, don't do
5 ; line tag F. Do H1^LRAPT2 instead.
6 ;21-Aug-01;WTY;Removed call to LRSPRPT2 which prints SNOMED codes.
7 ;
8 S A=0 F S A=+$O(^LR(LRDFN,LRSS,LRI,2,A)) Q:'A!(LR("Q")) D
9 .S T=+^LR(LRDFN,LRSS,LRI,2,A,0),X=$S($D(^LAB(61,T,0)):^(0),1:"")
10 .S T(1)=$P(X,"^"),T(8)=$P(X,"^",2)
11 .D SP Q:LR("Q")
12 .D T
13 Q:LR("Q")
14 I $D(LRS(99)),'+$G(LR("SPSM")) D ^LRSPRPT2
15 Q:LR("Q")
16 I $D(LRS(99)) W ! D
17 .S A=0 F S A=$O(^LR(LRDFN,LRSS,LRI,3,A)) Q:'A!(LR("Q")) D
18 ..D:$Y>(IOSL-12) F Q:LR("Q")
19 ..S X=+^LR(LRDFN,LRSS,LRI,3,A,0)
20 ..S X=^ICD9(X,0),X(9)=$P(X,"^"),X=$P(X,"^",3)
21 ..W !,"ICD code: ",X(9),?20 D:LR(69.2,.05) C^LRUA W X
22 Q
23SP ;
24 S C=0 F S C=$O(^LR(LRDFN,LRSS,LRI,2,A,5,C)) Q:'C!(LR("Q")) D
25 .S T(3)=^LR(LRDFN,LRSS,LRI,2,A,5,C,0)
26 .S Y=$P(T(3),"^",2),E=$P(T(3),"^",3)
27 .S T(4)=$P(T(3),"^")_":",T(4)=$P($P(LR(LRSS),T(4),2),";",1)
28 .D D^LRU S T(2)=Y
29 .D:$Y>(IOSL-12) F Q:LR("Q") D WP
30 Q
31WP ;
32 W !!,T(4)," ",E," Date: ",T(2)," ",!,T(1),!
33 D E S B=0
34 F LRZ=0:1 S B=$O(^LR(LRDFN,LRSS,LRI,2,A,5,C,1,B)) Q:'B!(LR("Q")) D
35 .D:$Y>(IOSL-12) F Q:LR("Q")
36 .S X=^LR(LRDFN,LRSS,LRI,2,A,5,C,1,B,0) D ^DIWP
37 Q:LR("Q") D:LRZ ^DIWW
38 Q
39E ;
40 K ^UTILITY($J) S DIWR=IOM-10,DIWL=10,DIWF="W"
41 Q
42T ;
43 S T(3)=T,T(4)=61 D EN
44 S M=0 F S M=$O(^LR(LRDFN,LRSS,LRI,2,A,2,M)) Q:'M!(LR("Q")) D
45 .S T(3)=+^LR(LRDFN,LRSS,LRI,2,A,2,M,0),T(4)=61.1 D EN Q:LR("Q") D
46 ..S N=0 F S N=$O(^LR(LRDFN,LRSS,LRI,2,A,2,M,1,N)) Q:'N!(LR("Q")) D
47 ...S T(3)=+^LR(LRDFN,LRSS,LRI,2,A,2,M,1,N,0),T(4)=61.2 D EN
48 Q:LR("Q")
49 S M=0 F S M=$O(^LR(LRDFN,LRSS,LRI,2,A,1,M)) Q:'M!(LR("Q")) D
50 .S T(3)=+^LR(LRDFN,LRSS,LRI,2,A,1,M,0),T(4)=61.4 D EN
51 Q:LR("Q")
52 S M=0 F S M=$O(^LR(LRDFN,LRSS,LRI,2,A,3,M)) Q:'M!(LR("Q")) D
53 .S T(3)=+^LR(LRDFN,LRSS,LRI,2,A,3,M,0),T(4)=61.3 D EN
54 Q
55EN ;also from LRAPT2
56 S C(1)=0
57 F S C(1)=$O(^LAB(T(4),T(3),"JR",C(1))) Q:'C(1)!(LR("Q")) D
58 .I $P(^LAB(T(4),T(3),"JR",C(1),0),"^",7) S T(9)=^(0),T(5)=1 D L
59 Q
60L ;
61 S X=$O(^LAB(T(4),T(3),"JR",C(1),1,0))
62 I X K T(5) D
63 .S X=0 F S X=$O(^LAB(T(4),T(3),"JR",C(1),1,X)) Q:'X D
64 ..S Y=$P(^LAB(T(4),T(3),"JR",C(1),1,X,0),"^")
65 ..I Y=$E(T(8),1,$L(Y)) S T(5)=1
66 Q:'$D(T(5))
67 D PGCHK
68 Q:LR("Q")
69 W ! D PGCHK Q:LR("Q")
70 W !,"Reference: "
71 D PGCHK Q:LR("Q")
72 W !,$P(T(9),"^")
73 D PGCHK Q:LR("Q")
74 W !,$P(T(9),"^",2)
75 D PGCHK Q:LR("Q")
76 W !
77 I $P(T(9),"^",3) D
78 .W $P(^LAB(95,$P(T(9),"^",3),0),"^")," vol.",$P(T(9),"^",4)
79 .W " pg.",$P(T(9),"^",5)
80 S Y=$P(T(9),"^",6) D D^LRU W " Date: ",Y
81 Q
82F ;
83 D F^LRAPF,^LRAPF
84 Q
85PGCHK ;
86 I $Y>(IOSL-12) D
87 .I LRSS="AU" D Q
88 ..I '+$G(LRSF515) D H1^LRAPT Q
89 ..D:+$G(LRSF515) FT^LRAURPT,H^LRAURPT
90 .D F
91 Q
92END ;
93 W $C(7),!!,"OK TO DELETE THE ",LRAA(1)," FINAL REPORT LIST"
94 S %=2 D YN^LRU
95 I %=1 K ^LRO(69.2,LRAA,2) S ^LRO(69.2,LRAA,2,0)="^69.23A^0^0" D Q
96 .W $C(7),!,"LIST DELETED !"
97 W !!,"FINE, LET'S FORGET IT",!
98 Q
Note: See TracBrowser for help on using the repository browser.