- 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
