source: WorldVistAEHR/trunk/r/ICR_IMMUNOLOGY_CASE_REGISTRY-IMR/IMRBKLOD.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.7 KB
Line 
1IMRBKLOD ;HCIOFO/FAI - LABORATORY DATA EXTRACT; 03/09/02 17:45
2 ;;2.1;IMMUNOLOGY CASE REGISTRY;**15**;Feb 09, 1998
3CHK ; Called from IMRODAT1 routine
4 D NOW^%DTC S (ENDDT,X1)=%
5 S X2=-40 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^IMRBKLOD(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=0
40 . F S IMRTST=$O(^LR(IMRRFN,IMRRTYP,IMRRD,IMRTST)) Q:IMRTST'>0 D
41 .. S IMRFLG=0 D ARRAY
42 .. Q:IMRFLG'=1
43 .. I IMRTST'>1 Q
44 .. S IMRVAL=$G(^LR(IMRRFN,IMRRTYP,IMRRD,IMRTST))
45 .. Q:IMRVAL=""
46 .. N IMRLINE,IMRNODE,IMRDD,IMRCDD,IMRDD
47 .. I $P(IMRVAL,U)["canc" Q ; test has been canceled.
48 .. I $P(IMRVAL,U)["CANC" Q ; test has been canceled.
49 .. S IMRVALUE=$P(IMRVAL,U,1,2)
50 .. S IMRLABT=$O(^LAB(60,"C",(IMRRTYP_";"_IMRTST_";1"),0)) ; get the lab test data name
51 .. I IMRLABT="" S IMRLABT="**PANEL**",(IMRNAM,IMRCST,IMRNLAB)=""
52 .. E D
53 ... S (IMNLT,IMWKL,IMRNAM,IMRCST,IMRNLAB)=""
54 ... S IMRLINE=$G(^LAB(60,IMRLABT,0))
55 ... Q:IMRLINE=""
56 ... S IMRCST=$$GET1^DIQ(60,IMRLABT,1,"I")
57 ... I IMRCST="" S IMRCST="COST UNKNOWN"
58 ... S IMRNAM=$$GET1^DIQ(60,IMRLABT,.01,"I")
59 ... Q:IMRNAM=""
60 ... S IMWKL=$P($G(^LAB(60,IMRLABT,64)),U,1)
61 ... S:IMWKL'="" IMNLT=$$GET1^DIQ(64,IMWKL,1,"E")
62 ... S:$G(IMNLT)="" IMNLT="NONLT"
63 ... D NLAB^IMRUTL ;get national lab name
64 ... S IMNLT=$E(IMNLT,1,5) ; get National lab test pointer
65 ... Q
66 .. D FILE
67 .. Q
68 . Q
69 Q
70ARRAY S NUM="" F S NUM=$O(IMRVALS(NUM)) Q:NUM="" I IMRTST=NUM S IMRFLG=1 Q
71 Q
72FILE ; File the code based on IMRRTYP
73 K IMRHLDR
74 I IMRRTYP="CH" D CHFILE
75 I IMRRTYP="SP" D SPFILE
76 I IMRRTYP="CY" D CYFILE
77 Q
78MIFILE ; the MI code to file it in temp
79 N IMRX,IMRRX,IMRVALL
80 S IMRRD=""
81 F S IMRRD=$O(^LR(IMRRFN,IMRRTYP,IMRRD)) Q:IMRRD="" D
82 .I '$D(^LR(IMRRFN,IMRRTYP,IMRRD,1)) Q
83 .S IMRRCD=$G(^LR(IMRRFN,IMRRTYP,IMRRD,1))
84 .Q:IMRRCD="" Q:$P(IMRRCD,U,2)'="F"
85 .S IMRRCD=$P(IMRRCD,U)
86 .Q:IMRRCD<IMRSD
87 .Q:IMRRCD>IMRED
88 .S IMRVALL=$G(^LR(IMRRFN,IMRRTYP,IMRRD,0))
89 .S IMRRX=IMRRTYP_U_(+$P(IMRVALL,U,1)\1)
90 .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)
91 .I $D(^LR(IMRRFN,IMRRTYP,IMRRD,1)) S IMRX=1 D BAC^IMRODLB2
92 .I $D(^LR(IMRRFN,IMRRTYP,IMRRD,2,0)) S IMRX=2 D GRAM^IMRODLB2
93 .I $D(^LR(IMRRFN,IMRRTYP,IMRRD,3,0)) S IMRX=3 D ORG^IMRODLB2
94 .I $D(^LR(IMRRFN,IMRRTYP,IMRRD,6,0)) S IMRX=6 D PAR^IMRODLB2
95 .I $D(^LR(IMRRFN,IMRRTYP,IMRRD,7,0)) S IMRX=7 D PARRPT^IMRODLB2
96 .I $D(^LR(IMRRFN,IMRRTYP,IMRRD,99)) S IMRX=99 D COMSP^IMRODLB2
97 S (IMRCHL,IMRSEND)=1
98 Q
99SPFILE ; the CH code to file it in temp
100 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^IMRODATA ;IMRVALUE is 2 pieces; data value and test result flag
101 I $G(IMRTRANS)
102 S (IMRCHL,IMRSEND)=1
103 ; same as CH
104 ;
105 Q
106CYFILE ; the CH code to file it in temp
107 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^IMRODATA ;IMRVALUE is 2 pieces; data value and test result flag
108 I $G(IMRTRANS)
109 S (IMRCHL,IMRSEND)=1
110 ; same as CH
111 Q
112CHFILE ; the CH code to file it in temp
113 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
114 S $P(^TMP($J,"IMRX",IMRC),U,8)=IMRNLAB ;national lab name or pointer
115 S $P(^TMP($J,"IMRX",IMRC),U,9)=IMNLT ; workload code
116 D ^IMRLBTY
117 D LCHK^IMRODATA
118 I $G(IMRTRANS)
119 S (IMRCHL,IMRSEND)=1
120 ; piece 2 (IMRD)=date specimen taken
121 ; piece 3 (IMRNAM)=name of test
122 ; piece 4 (IMRTST)=node of test
123 ; piece 5 (IMRCST)=test cost
124 ; piece 6 & 7(IMRVALUE)=data value^test result flag
125 ; piece 8 (IMRNLAB)=national lab name or pointer
126 ; piece 9 (IMNLT)=workload code file 64
127 Q
Note: See TracBrowser for help on using the repository browser.