LREPI5 ;VA/DALOI/SED-EMERGING PATHOGENS SEARCH ; 17-Oct-2014 09:22 ; MKK
;;5.2;LAB SERVICE;**281,1030,315,1031,1034**;NOV 1, 1997;Build 188
;
; Reference to ^DGPT supported by IA #418
; Reference to ^ICD9 supported by IA #10082
; Reference to ^ORD supported by IA #872
; Reference to PATS^PXRMXX supported by IA #3134
; Reference to VADPT supported by IA #10061
; Reference to ^AUPNVPOV supported by IA #3094
Q
;Called from LREPI
PTF ;SEARCH DISCHARGE DATES; NEED ADDITIONAL LATER SPECS
NEW ICD10DT ; IHS/MSC/MKK - LR*5.2*1034
D ICD10IDT(.ICD10DT)
;
S STDT=(LRRPS-.0001),ENDT=(LRRPE+.9999)
F S STDT=$O(^DGPT("ADS",STDT)) Q:+STDT'>0!(STDT>ENDT) D
.S IFN=0 F S IFN=$O(^DGPT("ADS",STDT,IFN)) Q:+IFN'>0 D
..Q:$P($G(^DGPT(IFN,0)),U,6)'=3
..I $P($G(^DGPT(IFN,300)),U,3)=1 D
...;S ICD9=$O(^ICD9("BA","482.84 ",0)) D ICD9
...; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034 - Take into account ICD-10 coding as well
...S:STDT<ICD10DT ICD9=$O(^ICD9("BA","482.84 ",0))
...S:STDT'<ICD10DT ICD9=$O(^ICD9("BA","A48.1 ",0))
...D ICD9
...; ----- END IHS/MSC/MKK - LR*5.2*1034
..I $D(^DGPT(IFN,70)) F LRI=10,11,16:1:24 D
...S ICD9=$P(^DGPT(IFN,70),U,LRI) D ICD9
..;SEARCH SUB FIELDS
..S LRMV=0 F S LRMV=$O(^DGPT(IFN,"M",LRMV)) Q:+LRMV'>0 D
...I $P($G(^DGPT(IFN,"M",LRMV,300)),U,3)=1 D
....; S ICD9=$O(^ICD9("BA","482.84 ",0)) D ICD9
....; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034 - Take into account ICD-10 coding as well
....S:STDT<ICD10DT ICD9=$O(^ICD9("BA","482.84 ",0))
....S:STDT'<ICD10DT ICD9=$O(^ICD9("BA","A48.1 ",0))
....D ICD9
....; ----- END IHS/MSC/MKK - LR*5.2*1034
...I $D(^DGPT(IFN,"M",LRMV,0)) F LRI=5:1:9,11:1:15 D
....S ICD9=$P(^DGPT(IFN,"M",LRMV,0),U,LRI) D ICD9
K IFN,LRMV,ICD9,LRI
Q
ICD9 ;CHECK ICD9 CODE AND SAVE
Q:+ICD9'>0
Q:'$D(^TMP($J,"ICD",+ICD9))
S LRPROT=$G(LRPROT,999999) S ^TMP($J,"ICDPROT",+ICD9,LRPROT)=""
S DFN=$P(^DGPT(IFN,0),U,1),ADMDT=$P(^DGPT(IFN,0),U,2)
S LRPATH=0 F S LRPATH=$O(^TMP($J,"ICD",+ICD9,LRPATH)) Q:+LRPATH'>0 D SET
Q
SET ;SET THE TMP GLOBAL
S LRPROT=$P(^LAB(69.5,LRPATH,0),U,7)
S LRCHK=0 D ADDCHK Q:LRCHK
S:'$D(^TMP($J,LRPROT,DFN,ADMDT)) ^TMP($J,LRPROT,DFN,ADMDT)="I"_U_IFN
S ^TMP($J,LRPROT,DFN,ADMDT,LRPATH,(9999999-ADMDT),"PTF")=IFN
Q
ADDCHK ;DO ADDITIONAL CHECKS HERE FOR AGE AND SEX SCREENING.
;
I '$G(DFN) S DFN=$G(LRPAT)
K VADM
I $G(DFN) D DEM^VADPT
;
I $P(^LAB(69.5,LRPATH,0),U,10)'="" D
.S LRSEX=$P(^LAB(69.5,LRPATH,0),U,10)
.I LRSEX="O"&$P(VADM(5),U,1)="M" S LRCHK=1 Q
.I LRSEX="O"&$P(VADM(5),U,1)="F" S LRCHK=1 Q
.I LRSEX'=$P(VADM(5),U,1) S LRCHK=1
I $P(^LAB(69.5,LRPATH,0),U,11)'=""!$P(^LAB(69.5,LRPATH,0),U,12)'="" D
.S LRBEF=$P(^LAB(69.5,LRPATH,0),U,11),LRAFT=$P(^LAB(69.5,LRPATH,0),U,12)
.I LRBEF'=""&($P(VADM(3),U,1)>LRBEF) S LRCHK=1
.I LRAFT'=""&($P(VADM(3),U,1)<LRAFT) S LRCHK=1
K LRBEF,LRSEX,LRAFT,VADM
Q
LREPI5 ;VA/DALOI/SED-EMERGING PATHOGENS SEARCH ; 17-Oct-2014 09:22 ; MKK
+1 ;;5.2;LAB SERVICE;**281,1030,315,1031,1034**;NOV 1, 1997;Build 188
+2 ;
+3 ; Reference to ^DGPT supported by IA #418
+4 ; Reference to ^ICD9 supported by IA #10082
+5 ; Reference to ^ORD supported by IA #872
+6 ; Reference to PATS^PXRMXX supported by IA #3134
+7 ; Reference to VADPT supported by IA #10061
+8 ; Reference to ^AUPNVPOV supported by IA #3094
+9 QUIT
+10 ;Called from LREPI
PTF ;SEARCH DISCHARGE DATES; NEED ADDITIONAL LATER SPECS
+1 ; IHS/MSC/MKK - LR*5.2*1034
NEW ICD10DT
+2 DO ICD10IDT(.ICD10DT)
+3 ;
+4 SET STDT=(LRRPS-.0001)
SET ENDT=(LRRPE+.9999)
+5 FOR
SET STDT=$ORDER(^DGPT("ADS",STDT))
IF +STDT'>0!(STDT>ENDT)
QUIT
Begin DoDot:1
+6 SET IFN=0
FOR
SET IFN=$ORDER(^DGPT("ADS",STDT,IFN))
IF +IFN'>0
QUIT
Begin DoDot:2
+7 IF $PIECE($GET(^DGPT(IFN,0)),U,6)'=3
QUIT
+8 IF $PIECE($GET(^DGPT(IFN,300)),U,3)=1
Begin DoDot:3
+9 ;S ICD9=$O(^ICD9("BA","482.84 ",0)) D ICD9
+10 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034 - Take into account ICD-10 coding as well
+11 IF STDT<ICD10DT
SET ICD9=$ORDER(^ICD9("BA","482.84 ",0))
+12 IF STDT'<ICD10DT
SET ICD9=$ORDER(^ICD9("BA","A48.1 ",0))
+13 DO ICD9
+14 ; ----- END IHS/MSC/MKK - LR*5.2*1034
End DoDot:3
+15 IF $DATA(^DGPT(IFN,70))
FOR LRI=10,11,16:1:24
Begin DoDot:3
+16 SET ICD9=$PIECE(^DGPT(IFN,70),U,LRI)
DO ICD9
End DoDot:3
+17 ;SEARCH SUB FIELDS
+18 SET LRMV=0
FOR
SET LRMV=$ORDER(^DGPT(IFN,"M",LRMV))
IF +LRMV'>0
QUIT
Begin DoDot:3
+19 IF $PIECE($GET(^DGPT(IFN,"M",LRMV,300)),U,3)=1
Begin DoDot:4
+20 ; S ICD9=$O(^ICD9("BA","482.84 ",0)) D ICD9
+21 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034 - Take into account ICD-10 coding as well
+22 IF STDT<ICD10DT
SET ICD9=$ORDER(^ICD9("BA","482.84 ",0))
+23 IF STDT'<ICD10DT
SET ICD9=$ORDER(^ICD9("BA","A48.1 ",0))
+24 DO ICD9
+25 ; ----- END IHS/MSC/MKK - LR*5.2*1034
End DoDot:4
+26 IF $DATA(^DGPT(IFN,"M",LRMV,0))
FOR LRI=5:1:9,11:1:15
Begin DoDot:4
+27 SET ICD9=$PIECE(^DGPT(IFN,"M",LRMV,0),U,LRI)
DO ICD9
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+28 KILL IFN,LRMV,ICD9,LRI
+29 QUIT
ICD9 ;CHECK ICD9 CODE AND SAVE
+1 IF +ICD9'>0
QUIT
+2 IF '$DATA(^TMP($JOB,"ICD",+ICD9))
QUIT
+3 SET LRPROT=$GET(LRPROT,999999)
SET ^TMP($JOB,"ICDPROT",+ICD9,LRPROT)=""
+4 SET DFN=$PIECE(^DGPT(IFN,0),U,1)
SET ADMDT=$PIECE(^DGPT(IFN,0),U,2)
+5 SET LRPATH=0
FOR
SET LRPATH=$ORDER(^TMP($JOB,"ICD",+ICD9,LRPATH))
IF +LRPATH'>0
QUIT
DO SET
+6 QUIT
SET ;SET THE TMP GLOBAL
+1 SET LRPROT=$PIECE(^LAB(69.5,LRPATH,0),U,7)
+2 SET LRCHK=0
DO ADDCHK
IF LRCHK
QUIT
+3 IF '$DATA(^TMP($JOB,LRPROT,DFN,ADMDT))
SET ^TMP($JOB,LRPROT,DFN,ADMDT)="I"_U_IFN
+4 SET ^TMP($JOB,LRPROT,DFN,ADMDT,LRPATH,(9999999-ADMDT),"PTF")=IFN
+5 QUIT
ADDCHK ;DO ADDITIONAL CHECKS HERE FOR AGE AND SEX SCREENING.
+1 ;
+2 IF '$GET(DFN)
SET DFN=$GET(LRPAT)
+3 KILL VADM
+4 IF $GET(DFN)
DO DEM^VADPT
+5 ;
+6 IF $PIECE(^LAB(69.5,LRPATH,0),U,10)'=""
Begin DoDot:1
+7 SET LRSEX=$PIECE(^LAB(69.5,LRPATH,0),U,10)
+8 IF LRSEX="O"&$PIECE(VADM(5),U,1)="M"
SET LRCHK=1
QUIT
+9 IF LRSEX="O"&$PIECE(VADM(5),U,1)="F"
SET LRCHK=1
QUIT
+10 IF LRSEX'=$PIECE(VADM(5),U,1)
SET LRCHK=1
End DoDot:1
+11 IF $PIECE(^LAB(69.5,LRPATH,0),U,11)'=""!$PIECE(^LAB(69.5,LRPATH,0),U,12)'=""
Begin DoDot:1
+12 SET LRBEF=$PIECE(^LAB(69.5,LRPATH,0),U,11)
SET LRAFT=$PIECE(^LAB(69.5,LRPATH,0),U,12)
+13 IF LRBEF'=""&($PIECE(VADM(3),U,1)>LRBEF)
SET LRCHK=1
+14 IF LRAFT'=""&($PIECE(VADM(3),U,1)<LRAFT)
SET LRCHK=1
End DoDot:1
+15 KILL LRBEF,LRSEX,LRAFT,VADM
+16 QUIT
