source: WorldVistAEHR/trunk/r/ICR_IMMUNOLOGY_CASE_REGISTRY-IMR/IMRLAB.m@ 1800

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

initial load of WorldVistAEHR
File size: 4.8 KB
Line 
1IMRLAB ;HCIOFO/SPS/FAI - LABORATORY DATA EXTRACT; 08/24/00 12:33
2 ;;2.1;IMMUNOLOGY CASE REGISTRY;**8,9,5,13,16,15**;Feb 09, 1998
3CHK ; Called from IMRDAT1 routine
4 N DA,DIE,DR,I,IMRCD4,IMRCD,IMRCDX,IMRCDXD,IMRCHL,IMRCST,IMRD
5 N IMRLRTY,IMRNAM,IMRNLAB,IMRRD,IMRRFN,IMRRJ,IMRRJ1,IMRRK,IMRRL
6 N IMRRTYP,IMRRX,IMRRX1,IMRRX2,IMRRX3,IMRRX4
7 N IMRPR4,IMRSFLG,IMRTEXT,IMRTST,IMRVAL,IMRXCAT
8 S IMRMI=0,IMRLAB=0
9 Q:'$D(^DPT(DFN,"LR")) ;quit if no lab data for patient
10 ; gather data for CHL segment from File 63 (Lab Data)
11 ; Restructering the data gathering of patient lab data
12 ; 1) Loop through the lab file for all data for that patient and grab
13 ; it.
14 K ^TMP($J,"IMRCNT")
15 S IMRRFN=^DPT(DFN,"LR"),I=0
16 S IMRLABTR="CH^MI^"
17 I +$G(IMRTRANS) S IMRLABTR=IMRLABTR_"SP^CY^"
18 F I=1:1:$S($G(IMRTRANS)=1:7,1:2) S IMRRTYP=$P(IMRLABTR,U,I) Q:IMRRTYP="" D LAB^IMRLAB(IMRRFN,IMRRTYP,IMRSD,IMRED)
19 Q
20 ;
21LAB(IMRRFN,IMRRTYP,IMRSD,IMRED) ;
22 ; This routine will Loop thourgh the lab global for the given
23 ; type and process the data
24 ; IMRRFN=Patient Lab DFN
25 ; IMRRTYP=Type of lab test "CH,MI,..."
26 ; IMRRD=the date to start the search in a reverse order
27 ;
28 N I,IMRLCT,IMRRD
29 I IMRRTYP="MI" D MIFILE Q
30 S IMRRD=(9999999-(IMRED+1))
31 S IMRLCT=$P($G(^LR(IMRRFN,IMRRTYP,0)),U,3) Q:IMRLCT=""
32 Q:IMRLCT<1
33 S IMRLCT=(9999999-IMRLCT)
34 Q:(IMRLCT<IMRSD) ; There is no lab test after this date
35 F S IMRRD=$O(^LR(IMRRFN,IMRRTYP,IMRRD)) Q:IMRRD<1 D
36 . N IMRDUZ,IMRH,IMRGD
37 . I '$D(^LR(IMRRFN,IMRRTYP,IMRRD,0)) Q
38 . S IMRGD=9999999-IMRRD
39 . Q:(IMRGD<IMRSD)
40 . Q:(IMRGD>IMRED)
41 . S IMRD=+$P($G(^LR(IMRRFN,IMRRTYP,IMRRD,0)),"^",1) S:IMRD>IMRLAB IMRLAB=IMRD
42 . S IMRTST=0
43 . F S IMRTST=$O(^LR(IMRRFN,IMRRTYP,IMRRD,IMRTST)) Q:IMRTST'>0 D
44 .. I IMRTST'>1 Q
45 .. S IMRVAL=$G(^LR(IMRRFN,IMRRTYP,IMRRD,IMRTST))
46 .. Q:IMRVAL=""
47 .. N IMRLINE,IMRNODE,IMRDD,IMRCDD,IMRDD
48 .. I $P(IMRVAL,U)["canc" Q ; test has been canceled.
49 .. I $P(IMRVAL,U)["CANC" Q ; test has been canceled.
50 .. S IMRVALUE=$P(IMRVAL,U,1,2)
51 .. S IMRLABT=$O(^LAB(60,"C",(IMRRTYP_";"_IMRTST_";1"),0)) ; get the lab test data name
52 .. I IMRLABT="" S IMRLABT="**PANEL**",(IMRNAM,IMRCST,IMRNLAB)=""
53 .. E D
54 ... S (IMNLT,IMWKL,IMRNAM,IMRCST,IMRNLAB)=""
55 ... S IMRLINE=$G(^LAB(60,IMRLABT,0))
56 ... Q:IMRLINE=""
57 ... S IMRCST=$$GET1^DIQ(60,IMRLABT,1,"I")
58 ... I IMRCST="" S IMRCST="COST UNKNOWN"
59 ... S IMRNAM=$$GET1^DIQ(60,IMRLABT,.01,"I")
60 ... Q:IMRNAM=""
61 ... S IMWKL=$P($G(^LAB(60,IMRLABT,64)),U,1)
62 ... S:IMWKL'="" IMNLT=$$GET1^DIQ(64,IMWKL,1,"E")
63 ... S:$G(IMNLT)="" IMNLT="NONLT"
64 ... D NLAB^IMRUTL ;get national lab name
65 ... S IMNLT=$E(IMNLT,1,5) ; get National lab test pointer
66 ... Q
67 .. D FILE
68 .. Q
69 . Q
70 Q
71FILE ; File the code based on IMRRTYP
72 K IMRHLDR
73 I IMRRTYP="CH" D CHFILE
74 I IMRRTYP="SP" D SPFILE
75 I IMRRTYP="CY" D CYFILE
76 Q
77MIFILE ; the MI code to file it in temp
78 N IMRX,IMRRX,IMRVALL
79 S IMRRD=""
80 F S IMRRD=$O(^LR(IMRRFN,IMRRTYP,IMRRD)) Q:IMRRD="" D
81 .I '$D(^LR(IMRRFN,IMRRTYP,IMRRD,1)) Q
82 .S IMRRCD=$G(^LR(IMRRFN,IMRRTYP,IMRRD,1))
83 .Q:IMRRCD="" Q:$P(IMRRCD,U,2)'="F"
84 .S IMRRCD=$P(IMRRCD,U)
85 .Q:IMRRCD<IMRSD
86 .Q:IMRRCD>IMRED
87 .S IMRVALL=$G(^LR(IMRRFN,IMRRTYP,IMRRD,0))
88 .S IMRRX=IMRRTYP_U_(+$P(IMRVALL,U,1)\1)
89 .S IMRRX=IMRRX_U_$P($G(^LAB(61,(+$P(IMRVALL,U,5)),0)),U)_U_$P($G(^LAB(62,(+$P(IMRVALL,U,11)),0)),U)
90 .I $D(^LR(IMRRFN,IMRRTYP,IMRRD,1)) S IMRX=1 D BAC^IMRLAB2
91 .I $D(^LR(IMRRFN,IMRRTYP,IMRRD,2,0)) S IMRX=2 D GRAM^IMRLAB2
92 .I $D(^LR(IMRRFN,IMRRTYP,IMRRD,3,0)) S IMRX=3 D ORG^IMRLAB2
93 .I $D(^LR(IMRRFN,IMRRTYP,IMRRD,6,0)) S IMRX=6 D PAR^IMRLAB2
94 .I $D(^LR(IMRRFN,IMRRTYP,IMRRD,7,0)) S IMRX=7 D PARRPT^IMRLAB2
95 .I $D(^LR(IMRRFN,IMRRTYP,IMRRD,99)) S IMRX=99 D COMSP^IMRLAB2
96 S (IMRCHL,IMRSEND)=1
97 Q
98SPFILE ; the CH code to file it in temp
99 S IMRC=IMRC+1,^TMP($J,"IMRX",IMRC)=$S(IMRRTYP="CH":"CHL",1:IMRRTYP)_U_(IMRD\1)_U_IMRNAM_U_IMRTST_U_IMRCST_U_IMRVALUE D LCHK^IMRDAT ;IMRVALUE is 2 pieces; data value and test result flag
100 I $G(IMRTRANS)
101 S (IMRCHL,IMRSEND)=1
102 ; same as CH
103 ;
104 Q
105CYFILE ; the CH code to file it in temp
106 S IMRC=IMRC+1,^TMP($J,"IMRX",IMRC)=$S(IMRRTYP="CH":"CHL",1:IMRRTYP)_U_(IMRD\1)_U_IMRNAM_U_IMRTST_U_IMRCST_U_IMRVALUE D LCHK^IMRDAT ;IMRVALUE is 2 pieces; data value and test result flag
107 I $G(IMRTRANS)
108 S (IMRCHL,IMRSEND)=1
109 ; same as CH
110 Q
111CHFILE ; the CH code to file it in temp
112 S IMRC=IMRC+1,^TMP($J,"IMRX",IMRC)=$S(IMRRTYP="CH":"CHL",1:IMRRTYP)_U_(IMRD\1)_U_IMRNAM_U_IMRTST_U_IMRCST_U_IMRVALUE ;IMRVALUE is 2 pieces; data value and test result flag
113 S $P(^TMP($J,"IMRX",IMRC),U,8)=IMRNLAB ;national lab name or pointer
114 S $P(^TMP($J,"IMRX",IMRC),U,9)=IMNLT ; workload code
115 D ^IMRLBTY
116 D LCHK^IMRDAT
117 I $G(IMRTRANS)
118 S (IMRCHL,IMRSEND)=1
119 ; piece 2 (IMRD)=date specimen taken
120 ; piece 3 (IMRNAM)=name of test
121 ; piece 4 (IMRTST)=node of test
122 ; piece 5 (IMRCST)=test cost
123 ; piece 6 & 7(IMRVALUE)=data value^test result flag
124 ; piece 8 (IMRNLAB)=national lab name or pointer
125 ; piece 9 (IMNLT)=workload code file 64
126 Q
Note: See TracBrowser for help on using the repository browser.