source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRRS12.m@ 724

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

initial load of WorldVistAEHR

File size: 3.2 KB
Line 
1LRRS12 ;SLC/DCM,BA/DALOI/FHS/DRH - INTERIM REPORT BY LOCATION (MANUAL QUEUE) ;2/19/91 11:39
2 ;;5.2;LAB SERVICE;**1,283**;Sep 27, 1994
3 ;from option LRRS
4BEGIN ;
5 K LRLLOC
6 S LRPRTPG=0
7 D:'$D(LRPARAM) ^LRPARAM
8 G:$G(LREND) ^LRRK Q:$G(LREND)
9 S:'$D(LRSINGLE) LRSINGLE=0
10ASKPG I 'LRPRTPG D
11 .S DIR(0)="Y",DIR("A")="Print address page",DIR("B")="NO"
12 .D ^DIR K DIR
13 .I Y S LRPRTPG=1
14 D LOC
15END ;
16 D ^LRRK
17 K LRLOCXY,LRX1,LRY1,OK,LRX13
18 Q
19LOC ;
20 K LRLLOC
21 S (LREND,LRSTOP)=0
22 S (LRONETST,LRONESPC,LRLLOC,LRFLOC)=""
23 S LRELOC="ZZZZZZZZ"
24 S LRLAB=$S($D(LRLABKY):1,1:0)
25 K DTOUT,DUOUT
26 S LREND=0
27 D DTRANG Q:$G(LREND)
28 D CHKLOC Q:$G(LREND)
29 Q
30QUIT ;
31 S LREND=1
32 Q
33DTRANG ;
34 K LRX13
35 S LREDT="T-7"
36 D ^LRWU3
37 S:($D(DUOUT))!($D(DTOUT)) LREND=1 Q:LREND
38 ;I LRSDT=LREDT S X1=LREDT,X2=1 D C^%DTC S LREDT=X
39 S LRSDT=LRSDT-.5
40 I LREDT=LRSDT S LRX13=1
41 S LRSWTCH=LRSDT,LRSDT=LREDT,LREDT=LRSWTCH K LRSWTCH
42 ;I LRSDT=LREDT S X1=LREDT,X2=1 D C^%DTC S LREDT=X
43 S LRODT=LRSDT
44 S LRDT=LRODT,LRDTXX=LRODT
45 S LRBDT=LRODT
46 S LRSD=LRODT,LRLAST=LREDT
47 ;S X1=LRLAST,X2=1 D C^%DTC S LRLAST=X
48DTSINGL ;
49 Q
50 ;EDITED 1-18-94
51CHKLOC ;
52 K LRNGCHK
53 D CHOOSE
54 Q:$G(LREND)
55 D @$S(LRLOC="S":"SELECT",LRLOC="R":"RANGE",1:"QUE")
56 Q
57CHOOSE ;
58 N Y
59 S LREND=0
60 K DIR
61 S DIR("A")="Please select one of the following"
62 S DIR(0)="S^S:Selected Locations;R:A Range of locations;A:All locations"
63 S DIR("?")="Enter the letter that cooresponds to what you want."
64 D ^DIR
65 S:($D(DUOUT))!($D(DTOUT)) LREND=1 Q:LREND
66 S LRLOC=Y
67 Q
68QUER ;
69 ;D QUE
70 Q
71NODATA ;
72 S LRNOD=1
73 W !,"No Reports for ",$$DTF^LRAFUNC1(LRODT),! Q
74 Q
75DIS ;
76 N I
77 F I=1:1:LRCNT W !,I,?4,LRLOCX(I) S I=I+1 Q:I>LRCNT!($G(LREND)) D
78 . W:$D(LRLOCX(I)) ?39," ",I,?44,LRLOCX(I)
79 W ! Q
80 Q
81 Q
82RANGE ;
83 S (DTOUT,DUOUT)=""
84 K LRLLOC1,LRLLOC
85 S LRNGCHK=1
86 N Y
87 K DIC
88 S DIC=44,DIC(0)="AEMQZ"
89 S DIC("A")="Select Starting Location: "
90 D ^DIC
91 I $D(DUOUT)!($D(DTOUT))!(Y=-1) S LREND=1 Q:LREND
92 S:Y'=-1 LRY7=$L($P(Y(0),U))
93 I $D(LRY7) S LRY8=$E($P(Y(0),U),LRY7,LRY7) D
94 . S LRY8=$A(LRY8)
95 . S LRY8=$C(LRY8-1)
96 . S LRY7=LRY7-1
97 . S LRFLOC=$E($P(Y,"^",2),1,LRY7)_LRY8
98 I '$D(LRFLOC) G RANGE
99 S DIC("A")="Select Ending Location: "
100 S (DTOUT,DUOUT)=""
101ENDING D ^DIC
102 I $D(DUOUT)!($D(DTOUT)) S LREND=1 Q:LREND
103 I Y=-1 G END
104 S:Y'=-1 LRELOC=$P(Y(0),U)_"Z"
105 K LRY7,LRY8,LRLOCXY
106 I +LRFLOC=0&(+LRELOC=0)&($A($E(LRFLOC,1,1))>$A($E(LRELOC,1,1))) D
107 . S LX8=1 D HELP QUIT
108 I +LRFLOC>0&(+LRELOC>0)&(LRFLOC>LRELOC) S LX9=1 D HELP QUIT
109 S LRX1=LRFLOC
110 F S LRX1=$O(^SC("B",LRX1)) Q:LRX1=""!(LRX1]LRELOC) D
111 . S LRY1=$O(^SC("B",LRX1,"0")) S LRY1=$P(^SC(LRY1,0),U,2) Q:LRY1=""
112 . S LRLLOC(LRY1)=LRY1
113 S OK=0,LRODT=LRDTXX-.5
114 D QUE
115 QUIT
116SELECT ;
117 K ^TMP("LR",$J)
118 S LRSCRN=24
119 N LRNOD,LRTAC
120 S LRLLOC=""
121 S LRDT=LRODT
122 D READ
123 S LRODT=LRDT D QUE
124 Q
125READ ;
126 S OK=0
127 K DIC
128 S DIC=44,DIC(0)="QAEZNM"
129 S DIC("S")="I $L($P(^(0),U,2))"
130 S X1=LRODT,X2=-1 D C^%DTC S LRODT=X
131 D ^DIC
132 Q:Y<0
133 S Y1=$P(Y(0),U,2)
134 S LRLLOC(Y1)=Y1
135 K DIC
136 G READ
137 Q
138HELP ;
139 W !!,"I cannot search a range of locations that are not in"
140 W " sequential order"
141 I $D(LX8) W !,"Please enter the starting and ending locations in" D
142 . W " ALPHABETICAL order" K LX8
143 I $D(LX9) W !,"Please enter the starting and ending locations in" D
144 . W " NUMERICAL order" K LX9
145 W !
146 G RANGE
147 Q
148QUE S %ZIS="MQ",ZTSAVE("^TMP(""LR"",$J,")="",ZTRTN="DQ^LRRS13" D IO^LRWU
149 Q
Note: See TracBrowser for help on using the repository browser.