source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LR7OB630.m@ 1604

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

initial load of WorldVistAEHR

File size: 2.7 KB
Line 
1LR7OB630 ;slc/dcm - Get Lab data from 63 only ;8/11/97
2 ;;5.2;LAB SERVICE;**121**;Sep 27, 1994
3EN(LABPAT,SS,IDT) ;Get data from 63
4 ;LABPAT=Lab Patient ID
5 ;SS=Subscript CH, MI, EM, CY, AU, SP, BB
6 ;IDT=Inverse D/T verified
7 Q:'$G(LABPAT)!('$G(IDT))!('$L($G(SS)))
8 N GOTCOM
9 I $L($T(@SS)) G @SS
10 Q
11CH ;Chem, Hem, Tox, Ria, Ser, etc.
12 N Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y8,Y9,Y10,Y11,Y12,ACC,AC,ACD,ACN,X,X0
13 Q:'$D(^LR(LABPAT,SS,IDT)) S X0=^(IDT,0)
14 D DFN
15 S (AC,Y1,Y3,Y4,Y11)="",Y2=+X0,Y5=+X0,Y6="",Y7=$P(X0,"^",11),Y8=+X0,Y9=$P(X0,"^",3),Y10=$P(X0,"^",5),Y12=$P(X0,"^",4),ACC=$P(X0,"^",6)
16 I $L(ACC) S X=$P(ACC," "),X=$O(^LRO(68,"B",X,0)) I X S AC=X,ACD=+$P(X0,"."),ACN=$P(ACC," ",3) S:'$D(^LRO(68,AC,1,ACD,1,ACN)) AC=""
17 I AC D 68 Q
18 D 69,63^LR7OB63(1,LRDFN,SS,IDT)
19 Q
20MI ;Microbiology
21 N Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y8,Y9,Y10,Y11,Y12,ACC,AC,ACD,ACN,X,X0
22 Q:'$D(^LR(LABPAT,SS,IDT)) S X0=^(IDT,0)
23 D DFN
24 S (AC,Y1,Y4,Y5,Y11)="",Y2=+X0,Y3=$P(X0,"^",11),Y6=$P(X0,"^",7),Y7=$P(X0,"^",8),Y8=$P(X0,"^",10),Y9=$P(X0,"^",3),Y10=$P(X0,"^",5),Y12=$P(X0,"^",4),ACC=$P(X0,"^",6)
25 I $L(ACC) S X=$P(ACC," "),X=$O(^LRO(68,"B",X,0)) I X S AC=X,ACD=+$P(X0,"."),ACN=$P(ACC," ",3) S:'$D(^LRO(68,AC,1,ACD,1,ACN)) AC=""
26 I AC D 68 Q
27 D 69,63^LR7OB63(1,LRDFN,SS,IDT)
28 Q
29BB ;Blood bank
30 N Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y8,Y9,Y10,Y11,Y12,ACC,AC,ACD,ACN,X,X0
31 Q:'$D(^LR(LABPAT,SS,IDT)) S X0=^(IDT,0)
32 D DFN
33 S (AC,Y1,Y4,Y5,Y11)="",Y2=+X0,Y3=$P(X0,"^",11),Y6=$P(X0,"^",7),Y7=$P(X0,"^",4),Y8=$P(X0,"^",10),Y9=$P(X0,"^",3),Y10=$P(X0,"^",5),Y12=$P(X0,"^",4),ACC=$P(X0,"^",6)
34 I $L(ACC) S X=$P(ACC," "),X=$O(^LRO(68,"B",X,0)) I X S AC=X,ACD=+$P(X0,"."),ACN=$P(ACC," ",3) S:'$D(^LRO(68,AC,1,ACD,1,ACN)) AC=""
35 I AC D 68 Q
36 D 69,63^LR7OB63(1,LRDFN,SS,IDT)
37 Q
38EM ;Electron Microscopy
39 G CY
40SP ;Surgical Pathology
41 G CY
42CY ;Cytology
43 N Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y8,Y9,Y10,Y11,Y12,ACC,AC,ACD,ACN,X,X0
44 Q:'$D(^LR(LABPAT,SS,IDT)) S X0=^(IDT,0)
45 D DFN
46 S (AC,Y1,Y3,Y4,Y5,Y10,Y11)="",Y2=+X0,Y6=$P(X0,"^",7),Y7=$P(X0,"^",8),Y8=$P(X0,"^",10),Y9=$P(X0,"^",3),Y12=$P(X0,"^",4),ACC=$P(X0,"^",6)
47 I $L(ACC) S X=$P(ACC," "),X=$O(^LRO(68,"B",X,0)) I X S AC=X,ACD=+$P(X0,"."),ACN=$P(ACC," ",3) S:'$D(^LRO(68,AC,1,ACD,1,ACN)) AC=""
48 I AC D 68 Q
49 D 69,63^LR7OB63(1,LRDFN,SS,IDT)
50 Q
51AU ;Autopsy
52 N X,X0,Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y8,Y9,Y10,Y11,Y12
53 Q:'$D(^LR(LABPAT,SS)) S X0=^(SS)
54 D DFN
55 S (Y1,Y3,Y4,Y5,Y8,Y10,Y11,Y12)="",Y2=+X0,Y6=$P(X0,"^",12),Y7=$P(X0,"^",5),Y9=$P(X0,"^",3)
56 D 69,63^LR7OB63(1,LRDFN,SS)
57 Q
58DFN ;Get patient stuff
59 S:'$D(DFN) DFN=$P(^LR(LABPAT,0),"^",3) S:'$D(LRDFN) LRDFN=LABPAT S:'$D(LRDPF) LRDPF=$P(^LR(LABPAT,0),"^",2)_$G(^DIC(+$P(^LR(LABPAT,0),"^",2),0,"GL"))
60 Q
6169 ;Set lrx(69
62 S ^TMP("LRX",$J,69)=Y1_"^"_Y2_"^"_Y3_"^"_Y4_"^"_Y5_"^"_Y6_"^"_Y7_"^"_Y8_"^"_Y9_"^"_Y10_"^"_Y11_"^"_Y12,^TMP("LRX",$J,69,1)=""
63 Q
6468 ;Go get data from file 68
65 D A68^LR7OB68(ACD,AC,ACN)
66 Q
Note: See TracBrowser for help on using the repository browser.