125 lines
4.7 KiB
Mathematica
125 lines
4.7 KiB
Mathematica
IMRBKLAB ;HCIOFO/FAI - LABORATORY DATA EXTRACT; 04/20/01 17:45 ; 6/13/02 2:19pm
|
|
;;2.1;IMMUNOLOGY CASE REGISTRY;**13,16,15,18**;Feb 09, 1998
|
|
CHK ; Called from IMRDAT1 routine
|
|
D NOW^%DTC S (ENDDT,X1)=%
|
|
S X2=-45 D C^%DTC S BEGDT=X
|
|
S IMRMI=0,IMRLAB=0,IMRFLG=0
|
|
Q:'$D(^DPT(DFN,"LR")) ;quit if no lab data for patient
|
|
; gather data for CHL segment from File 63 (Lab Data)
|
|
; Restructering the data gathering of patient lab data
|
|
; 1) Loop through the lab file for all data for that patient and grab
|
|
; it.
|
|
K ^TMP($J,"IMRBDL")
|
|
S IMRRFN=^DPT(DFN,"LR"),I=0
|
|
S IMRLABTR="CH^MI^"
|
|
I +$G(IMRTRANS) S IMRLABTR=IMRLABTR_"SP^CY^"
|
|
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)
|
|
Q
|
|
;
|
|
LAB(IMRRFN,IMRRTYP,IMRSD,IMRED) ;
|
|
; This routine will Loop thourgh the lab global for the given
|
|
; type and process the data
|
|
; IMRRFN=Patient Lab DFN
|
|
; IMRRTYP=Type of lab test "CH,MI,..."
|
|
; IMRRD=the date to start the search in a reverse order
|
|
;
|
|
N I,IMRLCT,IMRRD
|
|
S IMRRD=(9999999-(ENDDT+1))
|
|
S IMRLCT=$P($G(^LR(IMRRFN,IMRRTYP,0)),U,3) Q:IMRLCT=""
|
|
Q:IMRLCT<1
|
|
S IMRLCT=(9999999-IMRLCT)
|
|
F S IMRRD=$O(^LR(IMRRFN,IMRRTYP,IMRRD)) Q:IMRRD<1 D
|
|
. N IMRDUZ,IMRH,IMRGD
|
|
. I '$D(^LR(IMRRFN,IMRRTYP,IMRRD,0)) Q
|
|
. S IMRGD=9999999-IMRRD
|
|
. S IMRD=+$P($G(^LR(IMRRFN,IMRRTYP,IMRRD,0)),"^",1) S:IMRD>IMRLAB IMRLAB=IMRD
|
|
. S IMRCPD=+$P($G(^LR(IMRRFN,IMRRTYP,IMRRD,0)),"^",3)
|
|
. Q:(IMRCPD<BEGDT)
|
|
. Q:(IMRCPD>ENDDT)
|
|
. S IMRTST=1
|
|
. F S IMRTST=$O(^LR(IMRRFN,IMRRTYP,IMRRD,IMRTST)) Q:IMRTST'>0 D
|
|
.. S IMRVAL=$G(^LR(IMRRFN,IMRRTYP,IMRRD,IMRTST))
|
|
.. Q:IMRVAL=""
|
|
.. N IMRLINE,IMRNODE,IMRDD,IMRCDD,IMRDD
|
|
.. I $P(IMRVAL,U)["canc" Q ; test has been canceled.
|
|
.. I $P(IMRVAL,U)["CANC" Q ; test has been canceled.
|
|
.. S IMRVALUE=$P(IMRVAL,U,1,2)
|
|
.. S IMRLABT=$O(^LAB(60,"C",(IMRRTYP_";"_IMRTST_";1"),0)) ; get the lab test data name
|
|
.. I IMRLABT="" S IMRLABT="**PANEL**",(IMRNAM,IMRCST,IMRNLAB)=""
|
|
.. E D
|
|
... S (IMNLT,IMWKL,IMRNAM,IMRCST,IMRNLAB)=""
|
|
... S IMRLINE=$G(^LAB(60,IMRLABT,0))
|
|
... Q:IMRLINE=""
|
|
... S IMRCST=$$GET1^DIQ(60,IMRLABT,1,"I")
|
|
... I IMRCST="" S IMRCST="COST UNKNOWN"
|
|
... S IMRNAM=$$GET1^DIQ(60,IMRLABT,.01,"I")
|
|
... Q:IMRNAM=""
|
|
... S IMWKL=$P($G(^LAB(60,IMRLABT,64)),U,1)
|
|
... S:IMWKL'="" IMNLT=$$GET1^DIQ(64,IMWKL,1,"E")
|
|
... S:$G(IMNLT)="" IMNLT="NONLT"
|
|
... D NLAB^IMRUTL ;get national lab name
|
|
... S IMNLT=$E(IMNLT,1,5) ; get National lab test pointer
|
|
... Q
|
|
.. D FILE
|
|
.. Q
|
|
. Q
|
|
Q
|
|
ARRAY S NUM="" F S NUM=$O(IMRVALS(NUM)) Q:NUM="" I IMRTST=NUM S IMRFLG=1 Q
|
|
Q
|
|
FILE ; File the code based on IMRRTYP
|
|
K IMRHLDR
|
|
I IMRRTYP="CH" D CHFILE
|
|
I IMRRTYP="SP" D SPFILE
|
|
I IMRRTYP="CY" D CYFILE
|
|
Q
|
|
MIFILE ; the MI code to file it in temp
|
|
N IMRX,IMRRX,IMRVALL
|
|
S IMRRD=""
|
|
F S IMRRD=$O(^LR(IMRRFN,IMRRTYP,IMRRD)) Q:IMRRD="" D
|
|
.I '$D(^LR(IMRRFN,IMRRTYP,IMRRD,1)) Q
|
|
.S IMRRCD=$G(^LR(IMRRFN,IMRRTYP,IMRRD,1))
|
|
.Q:IMRRCD="" Q:$P(IMRRCD,U,2)'="F"
|
|
.S IMRRCD=$P(IMRRCD,U)
|
|
.Q:IMRRCD<IMRSD
|
|
.Q:IMRRCD>IMRED
|
|
.S IMRVALL=$G(^LR(IMRRFN,IMRRTYP,IMRRD,0))
|
|
.S IMRRX=IMRRTYP_U_(+$P(IMRVALL,U,1)\1)
|
|
.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)
|
|
.I $D(^LR(IMRRFN,IMRRTYP,IMRRD,1)) S IMRX=1 D BAC^IMRLAB2
|
|
.I $D(^LR(IMRRFN,IMRRTYP,IMRRD,2,0)) S IMRX=2 D GRAM^IMRLAB2
|
|
.I $D(^LR(IMRRFN,IMRRTYP,IMRRD,3,0)) S IMRX=3 D ORG^IMRLAB2
|
|
.I $D(^LR(IMRRFN,IMRRTYP,IMRRD,6,0)) S IMRX=6 D PAR^IMRLAB2
|
|
.I $D(^LR(IMRRFN,IMRRTYP,IMRRD,7,0)) S IMRX=7 D PARRPT^IMRLAB2
|
|
.I $D(^LR(IMRRFN,IMRRTYP,IMRRD,99)) S IMRX=99 D COMSP^IMRLAB2
|
|
S (IMRCHL,IMRSEND)=1
|
|
Q
|
|
SPFILE ; the CH code to file it in temp
|
|
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
|
|
I $G(IMRTRANS)
|
|
S (IMRCHL,IMRSEND)=1
|
|
; same as CH
|
|
;
|
|
Q
|
|
CYFILE ; the CH code to file it in temp
|
|
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
|
|
I $G(IMRTRANS)
|
|
S (IMRCHL,IMRSEND)=1
|
|
; same as CH
|
|
Q
|
|
CHFILE ; the CH code to file it in temp
|
|
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
|
|
S $P(^TMP($J,"IMRX",IMRC),U,8)=IMRNLAB ;national lab name or pointer
|
|
S $P(^TMP($J,"IMRX",IMRC),U,9)=IMNLT ; workload code
|
|
D ^IMRLBTY
|
|
D LCHK^IMRDAT
|
|
I $G(IMRTRANS)
|
|
S (IMRCHL,IMRSEND)=1
|
|
; piece 2 (IMRD)=date specimen taken
|
|
; piece 3 (IMRNAM)=name of test
|
|
; piece 4 (IMRTST)=node of test
|
|
; piece 5 (IMRCST)=test cost
|
|
; piece 6 & 7(IMRVALUE)=data value^test result flag
|
|
; piece 8 (IMRNLAB)=national lab name or pointer
|
|
; piece 9 (IMNLT)=workload code file 64
|
|
Q
|