source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRCAPV1.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: 4.0 KB
Line 
1LRCAPV1 ;SLC/FHS-DETERMINE CAP AND STUFF INTO LRO(68 PART 1 ;12/3/1997
2 ;;5.2;LAB SERVICE;**42,119,153,221**;Sep 27, 1994
3LOOK ;from LRVER3,LRVR3,LAMIAUT4,LRMIV1,LRMIV2
4 Q:'$P(LRPARAM,U,14)!('$P($G(^LRO(68,+LRAA,0)),U,16)) I $D(XRTL) S XRTN="LRCAPV1" D T0^%ZOSV ; START RESPONSE TIME LOGGING
5 Q:'$D(^LRO(68,+LRAA,1,LRAD,1,LRAN,0))#2
6 S LRSSC=$G(^LRO(68,+LRAA,1,LRAD,1,LRAN,5,1,0)) Q:'$L(LRSSC) L +^LRO(68,+LRAA,1,LRAD,1,LRAN,4)
7 I $D(LRSB) S A1=0 F S A1=$O(LRSB(A1)) Q:A1<1 S LRT=+$G(^TMP("LR",$J,"TMP",A1)),LRT("P")=$G(^TMP("LR",$J,"TMP",A1,"P")) I LRT D L60A
8 N LRURGW
9 K LRT S (LRTT,LRT)=0,LRURGW=9
10 F S LRTT=$O(^LRO(68,+LRAA,1,LRAD,1,LRAN,4,LRTT)) Q:LRTT<.5 I $D(^(LRTT,0))#2,$E($P(^(0),U,6))'="*" S LRURGW=$S($P(^(0),U,2)<LRURGW:$P(^(0),U,2),1:LRURGW) D
11 . I LRSS'="MI",'$P(^LRO(68,+LRAA,1,LRAD,1,LRAN,4,LRTT,0),U,7) S LRTS(LRTT)=LRTT D RES S LRT=LRTT D L78 Q
12 . S LRTS(LRTT)=LRTT D RES S LRT=LRTT D L78 Q
13 D:LRSS="MI" ^LRCAPVM S LRADD=0 I $D(LRSB),$O(LRSB(0)) F LRT=0:0 S LRT=$O(LRCDEF(LRT)) Q:'LRT D L60
14 K A1,NODE,LRADD,LRSSC,LRTIME,NODE,ADDX,A,LRCODE,P,LRP,LRCNT,NODE0,X,LRPN L -^LRO(68,+LRAA,1,LRAD,1,LRAN,4)
15 I $D(XRT0) S XRTN="LOOK^LRCAPV1" D T1^%ZOSV ; STOP RESPONSE TIME LOGGING
16 Q
17RES K LRTIME Q:'$D(^LRO(68,+LRAA,1,LRAD,1,LRAN,0))#2
18 Q:$E($P(^LRO(68,+LRAA,1,LRAD,1,LRAN,4,LRTT,0),U,6))="*"
19 I $G(LRSS)'="MI" Q:$D(^LRO(68,+LRAA,1,LRAD,1,LRAN,4,LRTT,0))#2&('$P(^(0),U,5)) S LRTIME=$P(^(0),U,5)
20 S LRT=LRTT S:'$D(LRTIME) LRTIME=$$NOW^XLFDT
21 S:'$D(^LRO(68,+LRAA,1,LRAD,1,LRAN,4,LRTT,1,0))#2 ^(0)="^68.14P^" S NODE=^(0)
22 I $D(^LAB(60,LRTT,0)),'$L($P(^(0),U,5)) S LRT=LRTT D L60,ETIO3
23 ;D L78
24OUT Q
25L60A Q:$P(LRSB(A1),U)=""!($P(LRSB(A1),U)="canc")!($P(LRSB(A1),U)="pending") D L60,ETIOY
26 Q
27L60 F A=0:0 S A=$O(^LAB(60,LRT,9,A)) Q:A<1 I $G(^(A,0)) S LRCODE=^(0),P=+$P(LRCODE,U,4),LRP=+LRCODE,LRCNT=$S($P(LRCODE,U,3):$P(LRCODE,U,3),1:1),LRCODE=$P(LRCODE,U,2),LRNOCODE=0 D:'$P(LRCODE,".",2)&(LRCDEF>0)&('P) SET^LRCAPV1A D STUF
28 Q
29L78 I $D(LRT),$D(LRCDEF)#2,$P($G(^LRO(68,+LRAA,1,LRAD,1,LRAN,4,LRT,0)),U,5) S X=^(0) I '$P(X,U,7) S $P(X,U,7)=1,$P(X,U,8)=LRCDEF,^(0)=X Q
30 Q
31STUF I $D(LRNOCODE) Q:LRNOCODE I $G(LRSS)'="MI",$D(^LRO(68,+LRAA,1,LRAD,1,LRAN,4,LRT,0)),'$P(^(0),U,5) Q
32 ;I $L($P($G(^LRO(68,+LRAA,1,LRAD,1,LRAN,4,LRT,0)),U,8)) Q
33 I $G(LRSS)="MI",'$D(^LRO(68,+LRAA,1,LRAD,1,LRAN,4,LRT,0)) Q
34STUFE ;
35 Q:$E($P($G(^LRO(68,+LRAA,1,LRAD,1,LRAN,4,LRT,0)),U,6))="*"
36 S LRNOCODE=0 I '$D(LRADD),$D(^LRO(68,+LRAA,1,LRAD,1,LRAN,4,LRT,0))#2,'$P(^(0),U,5) Q
37 Q:'$D(LRADD)&($P($G(^LRO(68,+LRAA,1,LRAD,1,LRAN,4,LRT,0)),U,7))
38 D SET^LRCAPV1S
39STUFI ;from LRVER3A,LRWLST12
40 Q:'$P(LRPARAM,U,14)!('$P($G(^LRO(68,+LRAA,0)),U,16)) S ^LRO(68,"AA",LRAA_"|"_LRAD_"|"_LRAN_"|"_LRT)=""
41 Q
42ETIO ;from LRMIBUG
43 Q:'$P(LRPARAM,U,14)!('$P($G(^LRO(68,+LRAA,0)),U,16)) L +^LRO(68,+LRAA,1,LRAD,1,LRAN,4):1 I '$T W !!?10,"Someone else is editing this entry",$C(7),!! Q
44DIY S LRT=LRTS,LRADD="" Q:'$D(^LRO(68,+LRAA,1,LRAD,1,LRAN,0))#2
45 S:'$D(^LRO(68,+LRAA,1,LRAD,1,LRAN,4,LRT,1,0))#2 ^(0)="^68.14PA^" S NODE0=^(0) S LRTIME=$$NOW^XLFDT,GLB="^LAB(61.2,+LRBG1,9,A)" D ETIOL,L78
46 K LRADD L -^LRO(68,+LRAA,1,LRAD,1,LRAN,4)
47 Q
48ETIOY Q:'$P(LRPARAM,U,14)!('$P($G(^LRO(68,+LRAA,0)),U,16)) S:$G(LRTT) LRT=+LRTT Q:'$G(LRT) I $D(LRT),$D(^LRO(68,+LRAA,1,LRAD,1,LRAN,4,LRT,0)),'$P(^(0),U,5) Q
49 Q:$E($P($G(^LRO(68,+LRAA,1,LRAD,1,LRAN,4,$G(LRT),0)),U,6))="*"
50ETIO3 Q:'$G(LRT) I $P($G(LRSSC),U,2) S LRSSCX=$O(^LAB(60,LRT,3,"B",$P(LRSSC,U,2),0)) I LRSSCX S GLB="^LAB(60,LRT,3,LRSSCX,9,A)" D ETIOL
51 Q
52ETIOL F A=0:0 S A=$O(@(GLB)) Q:A<.5 I $D(^(A,0)) S LRCODE=^(0),LRP=+LRCODE,LRCNT=$S(+$P(LRCODE,U,3):$P(LRCODE,U,3),1:1),LRCODE=$P(LRCODE,U,2) D STUFE
53 Q
54ENDIY ;Entry point for non microbiology accessions not using bacteria
55 ;execute code. The calling point is the mumps x-ref on the .01 node
56 ;each etiology selection field
571 ;
58 Q:'$P($G(LRPARAM),U,14)!('$P($G(^LRO(68,+$G(LRAA),0)),U,16))
59 Q:'$G(LRAA)!('$G(LRAN))!('$G(LRAD))!('$G(LRANOK))!('$G(DUZ(2)))!('$G(LRTS))
60 L +^LRO(68,+LRAA,1,LRAD,1,LRAN,4)
61 S LRBG1=X I '$L($G(^LAB(61.2,+$G(LRBG1),0))) L -^LRO(68,+LRAA,1,LRAD,1,LRAN,4) K LRBG1 Q
62 N X,DIC,DIE,DA,D0,LRT,GLB,LRCODE,A,I,LRADD
63 D DIY K LRBG1
64 Q
Note: See TracBrowser for help on using the repository browser.