source: FOIAVistA/tag/r/AUTOMATED_LAB_INSTRUMENTS-LA/LAMIVTL2.m@ 628

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

initial load of FOIAVistA 6/30/08 version
File size: 6.6 KB
Line 
1LAMIVTL2 ;DAL/HOAK 3rd vitek literal verification routine
2 ;;5.2;AUTOMATED LAB INSTRUMENTS;**12**;Sep 27,1994
3INIT ;
4CONTROL ;
5 S OK=1
6 K LRBUX
7 K LRKEEP
8 D PROBE
9 I 'OK QUIT
10 K ^TMP($J,"LR"),^TMP($J,"LA"),^LAH(LRLL,1,"VITLIT"),^TMP($J,"LROUT")
11 S LRIFN=0
12 F S LRIFN=$O(LRIFN(LRIFN)) Q:LRIFN'>0 D LAH Q:'OK
13 D CALL
14 S LRIFN=0
15 W @IOF
16 F S LRIFN=$O(LRIFN(LRIFN)) Q:LRIFN'>0 D LAH1 Q:'OK
17 D LAH2
18 D ^LAMIVTL4 ;--->EDIT, OR enter itials
19 Q
20PROBE ;---------------------------------------------------------------------
21 ; If data here it looks like ^LR(LRDFN,"MI",LRIDT,3,LRPIC,DRUGNODE)
22 ; where LRPIC is not the IFN in etiology, that is found at
23 ; $P(^(3,LRBUG,0),U)
24 W !!,"Reviewing for previously entered results:"
25 I '$D(^LR(LRDFN,LRSUB,LRIDT,3)) D ;------NO DATA IN LR FOR THIS ACCN
26 . W !,"NO PREVIOUS DATA FOR THIS ACCN" QUIT
27 S LRPIC=0
28DISPLAY ;
29 K LRDOS
30 W @IOF
31 K DIR
32 S DIR(0)="E"
33 F S LRPIC=$O(^LR(LRDFN,LRSUB,LRIDT,3,LRPIC)) Q:LRPIC'>0!('OK) D
34 . S LRBUG=$P(^LAB(61.2,+^LR(LRDFN,LRSUB,LRIDT,3,LRPIC,0),0),U)
35 . W !,"Isolate (",LRPIC," )" S LRDOS=1
36 . W !," ",LRBUG
37 . S LRRX=1
38 . F S LRRX=$O(^LR(LRDFN,LRSUB,LRIDT,3,LRPIC,LRRX)) Q:+LRRX'>0 D
39 .. S LRNTRP=^LR(LRDFN,LRSUB,LRIDT,3,LRPIC,LRRX)
40 .. S LRDRUG=$P(^LAB(62.06,$O(^LAB(62.06,"AD",LRRX,0)),0),U)
41 .. W !,$E(LRDRUG,1,30),?32,$P(LRNTRP,U),?38,$P(LRNTRP,U,2)
42 .. S LRD0(LRRX)=LRNTRP
43 . D CHK Q:'OK
44 K DIR
45 Q
46CHK ;
47 Q:$GET(LRDOS)'>0
48 ; what do you want to do if data in already in ^LR
49 W !!,"Look what I found in ",PNM,"'S report.",!,"What do you want me to do with it?"
50 S DIR(0)="S^1:Overwrite;2:Keep;3:Edit"
51 S DIR("A")="Please choose one of the courses of actions:"
52 D ^DIR
53 I $D(DTOUT)!($D(DUOUT)) S OK=0 QUIT
54 ;I Y=3 D VERIFY^LAMIVTL4 QUIT ;edit existing isolate in ^LR
55 I Y=3 D EDIT^LAMIVTL6 D CHKG S LRKEEP(LRPIC)=1 QUIT ;edit existing isolate in ^LR
56 S LRKEEP(LRPIC)=$S(Y=1!(Y=""):0,1:1)
57 I Y=1&($G(LRNOTO)=1) D G CHK
58 . W !,"I will not overwrite verified Data!",*7,*7,!! Q
59 Q
60CHKG ;
61 I $G(^LR(LRDFN,LRSUB,LRIDT,3,LRIDT)) K ^LR(LRDFN,LRSUB,LRIDT,3,LRIDT)
62 Q
63GETBUG ;
64 D ASK ;Q:'OK
65 S $P(^LR(LRDFN,LRSUB,LRIDT,3,LRISO,0),U,2)=$G(LRQUANT(LRISO)),$P(^(0),U,3)=""
66 S ^LR(LRDFN,LRSUB,LRIDT,3,LRISO,0)=$O(^LAB(61.2,"B",LRBUG,""))
67 ;S ^LR(LRDFN,LRSUB,LRIDT,3,LRISO,1,0)="63.31A"
68 ;S $P(^LR(LRDFN,LRSUB,LRIDT,3,LRISO,1,0),U,3)=1,$P(^(0),U,4)=1
69 D ORGCOM
70 Q
71 ;----------------------------------------------------------------------
72ASK ; From LAMIAUT2 BY FHS
73 K X2
74 I $L($P(^LAH(LRLL,1,$P(LRNOD,U),3,$P(LRNOD,U,2),0),U,2)) S X2=$P(^(0),U,2)
75 S LREND=0
76 W !!,LRISO,". ENTER QUANTITY FOR ( "_LRBUG_" ) : " S LRORGCNT=LRORGCNT+1
77 W $S($D(X2):X2_" // ",1:" ")
78 R X:DTIME S:X["^" LREND=1 S:LREND OK=0 Q:'OK
79 I $D(X2),'$L(X),X'="@" S X=X2
80 S:$E(X)="^" LREND=1 S:LREND OK=0 Q:'OK
81 ;I X="@" S $P(^LAH(LRLL,1,LRIFN,3,LRISO,0),U,2)="" Q
82 I $E(X)="?" W !?7,"Enter 2-68 characters or a Lab Description" K DIC S X="?",DIC="^LAB(62.5,",DIC(0)="Q",DIC("S")="I LRMICOMS[$P(^(0),U,4)" D ^DIC K DIC G ASK
83 I $L(X) X LRMICOM I '$D(X) W !?7,"Enter 2-68 characters " G ASK
84 I $L(X) W !,X_" " S %=1 D YN^DICN G:%'=1 ASK I $L(X) D
85 . S $P(^LAH(LRLL,1,$P(LRNOD,U),3,$P(LRNOD,U,2),0),U,2)=X
86 . S LRQUANT(LRISO)=X
87 Q
88ORGCOM ;
89 I $D(^LR(LRDFN,LRSUB,LRIDT,3,LRISO,1,1,0)) S LRCMNT=^(0)
90 S X2=$G(LRCMNT)
91 W !,"COMMENT: "
92 W $S($D(X2):X2_" // ",1:" ")
93 R X:DTIME S:X["^" LREND=1 S:LREND OK=0 Q:'OK
94 I $D(X2),'$L(X),X'="@" S X=X2
95 S:$E(X)="^" LREND=1 S:LREND OK=0 Q:'OK
96 I X="@" S ^LR(LRDFN,LRSUB,LRIDT,3,LRISO,1,1,0)="" G ORGCOM Q
97 I $E(X)="?" W !?7,"Enter 2-68 characters or a Lab Description" K DIC S X="?",DIC="^LAB(62.5,",DIC(0)="Q",DIC("S")="I LRMICOMS[$P(^(0),U,4)" D ^DIC K DIC G ASK
98 I $L(X) X LRMICOM I '$D(X) W !?7,"Enter 2-68 characters " G ASK
99 I $L(X) W !,X_" " S %=1 D YN^DICN G:%'=1 ASK I $L(X) D
100 . S ^LR(LRDFN,LRSUB,LRIDT,3,LRISO,1,1,0)=X
101 Q
102LAH ;
103 ;W @IOF
104 S LRISO=0
105 S LRORGCNT=0
106 ; Display all bugs at begining
107BUILD F S LRISO=$O(^LAH(LRLL,1,LRIFN(LRIFN),3,LRISO)) Q:+LRISO'>0!('OK) D
108 . I $G(LRKEEP(LRISO)) K ^LAH(LRLL,1,LRIFN(LRIFN),3) QUIT
109 . S LRRX=0
110 . S LRCMNT=$P($G(^LAH(LRLL,1,LRIFN(LRIFN),1,LRISO,1,0)),U)
111 . S LRBACT=$P($G(^LAH(LRLL,1,LRIFN(LRIFN),1,LRISO,1,0)),U,2)
112 . S LRBUG=$P(^LAB(61.2,+^LAH(LRLL,1,LRIFN(LRIFN),3,LRISO,0),0),U)
113 . S ^TMP($J,"LR",LRISO,LRBUG)=LRIFN(LRIFN)_U_LRISO
114 . ;-----LIST TO CHECK FOR DUPS IN LAH <--------\/
115 . S LRBUX=^LAH(LRLL,1,LRIFN(LRIFN),3,LRISO,0)
116 . S ^LAH(LRLL,1,"VITLIT",3,LRISO,LRIFN(LRIFN),+LRBUX_$P(LRBUX,U,3))=""
117 QUIT
118CALL ;
119 ;-----------------ALL BUGS AT ONCE---------------
120 S LRISO=0
121 F S LRISO=$O(^TMP($J,"LR",LRISO)) Q:LRISO'>0 D
122 . S LRBUG=0
123 . F S LRBUG=$O(^TMP($J,"LR",LRISO,LRBUG)) Q:LRBUG="" S LRNOD=^(LRBUG) D
124 .. D GETBUG Q:'OK
125 QUIT
126 ;-----------------------------------------------------------------------
127LAH1 ; Display drugs
128 ;W @IOF
129 S LRISO=0
130 F S LRISO=$O(^LAH(LRLL,1,"VITLIT",3,LRISO)) Q:+LRISO'>0!('OK) D
131 . Q:$G(LRKEEP(LRISO))
132 . S LRNORK=0
133 . F S LRNORK=$O(^LAH(LRLL,1,"VITLIT",3,LRISO,LRNORK)) Q:LRNORK'>0 D
134 .. S LRBUX=""
135 .. S LRBUX=$O(^LAH(LRLL,1,"VITLIT",3,LRISO,LRNORK,LRBUX))
136 .. S ^TMP($J,"LROUT",LRISO,LRBUX)=LRNORK
137 . D PRESTO
138 . S LRRX=0
139 . S LRBUG=$P(^LAB(61.2,+^LAH(LRLL,1,LRIFN(LRIFN),3,LRISO,0),0),U)
140 . S LRBUX=^LAH(LRLL,1,LRIFN(LRIFN),3,LRISO,0)
141 . S ^TMP($J,"LA",3,LRISO,LRIFN(LRIFN),+LRBUX_$P(LRBUX,U,3))=""
142 . D CHKLAH^LAMIVTL3 Q:'LRNOT
143 QUIT
144LAH2 ;
145 ; Print drugs
146 S LRISO=0
147 F S LRISO=$O(^TMP($J,"LROUT",LRISO)) Q:LRISO'>0 D
148 . S LRPIN=0
149 . F S LRPIN=$O(^TMP($J,"LROUT",LRISO,LRPIN)) Q:LRPIN="" S LRIFN=^(LRPIN),LRIFN(LRIFN)=LRIFN D
150 .. K ^TMP("VITNAME")
151 .. S LRBUG=$P(^LAB(61.2,+LRPIN,0),U)
152 .. W @IOF
153 .. W !,"Isolate (",LRISO," )"
154 .. W !," ",LRBUG
155 .. W !," ","CARD "_$P(^LAH(LRLL,1,LRIFN(LRIFN),2,2),U,2)
156 .. S LRRX=1
157 .. F S LRRX=$O(^LAH(LRLL,1,LRIFN(LRIFN),3,LRISO,LRRX)) Q:LRRX="" D
158 ... S LRNTRP=^LAH(LRLL,1,LRIFN(LRIFN),3,LRISO,LRRX)
159 ... S LRDRUG=$P(^LAB(62.06,$O(^LAB(62.06,"AD",LRRX,0)),0),U)
160 ... S ^TMP("VITNAME",LRDRUG)=LRNTRP
161 ... ;W !,$E(LRDRUG,1,30),?32,LRNTRP
162 .. S LRDRUG="" F S LRDRUG=$O(^TMP("VITNAME",LRDRUG)) Q:LRDRUG="" D
163 ... W !,$E(LRDRUG,1,30),?32,$P(^TMP("VITNAME",LRDRUG),U),?52,$P(^(LRDRUG),U,2),?65,$P(^(LRDRUG),U,3) D CHKPAGE Q:'OK
164 .. Q:'OK
165 .. D PAUSE
166 .. D SET^LAMIVTL3
167 Q:'OK
168 Q:'$G(LRIFN) S:$G(LRINTER) LRIFN(LRIFN)=LRINTER
169 Q
170PRESTO ;
171 ; --- KEEP LRIFN FOR FUTURE USE---------------<<<<<<<<
172 S LRINTER=LRIFN(LRIFN)
173 S LRPLK=0
174 S LRPLK=$O(^LAH(LRLL,1,"VITLIT",3,LRISO,LRPLK))
175 S LRIFN(LRIFN)=LRPLK
176 Q
177PAUSE ;
178 S LRDIE=$G(^LAH(LRLL,1,LRIFN(LRIFN),3,LRISO,1,0)) ;SET COMMENT
179 S LRCMNT=$P(LRDIE,U)
180 S LRBACT=$P(LRDIE,U,2)
181 ;R !!,"Touch enter to continue",DHZX:DTIME
182 K DIR
183 S DIR(0)="E"
184 D ^DIR
185 I $D(DUOUT) S OK=0
186 Q
187CHKPAGE ;
188 I IOSL-$Y>4 QUIT
189 K DIR
190 S DIR(0)="E"
191 D ^DIR
192 I Y["^" S OK=0 QUIT
193 W @IOF
194 Q
Note: See TracBrowser for help on using the repository browser.