source: WorldVistAEHR/trunk/r/ICR_IMMUNOLOGY_CASE_REGISTRY-IMR/IMRBKLAB.m@ 792

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

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