- LREPI5 ;DALOI/SED,WOIFO/PMK - EMERGING PATHOGENS SEARCH ;31 Dec 2014 11:03 AM
- ;;5.2;LAB SERVICE;**281,315,421,442**;Sep 27, 1994;Build 15
- ; Reference to ^DGPT supported by IA #418
- ; Reference to DGPTFUT supported by IA #6130
- ; 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
- ; Reference to $$CODEN^ICDEX supported by IA #5747
- Q
- ;Called from LREPI
- PTF ;SEARCH DISCHARGE DATES; NEED ADDITIONAL LATER SPECS
- N J,PTFICD ; ICD array built by PTFICD^DGPTFUT
- S STDT=(LRRPS-.0001),ENDT=(LRRPE+.9999)
- F S STDT=$O(^DGPT("ADS",STDT)) Q:+STDT'>0!(STDT>ENDT) D
- .K LRICDX,LRCSYS S LRCSYS=$$ICDSYS^LREPICD(STDT,"D"),LRICDX=$S(LRCSYS="ICD":0,LRCSYS="10D":1,1:-1) Q:LRICDX=-1
- .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
- ...I 'LRICDX S LRICDIEN=+$$CODEN^ICDEX("482.84 ",80) D CHKICD
- ...I LRICDX F LRXCODE="A48.1","A48.2","A48.8" D
- ....S LRICDIEN=+$$CODEN^ICDEX(LRXCODE,80) D CHKICD
- ..; I $D(^DGPT(IFN,70)) F LRI=10,11,16:1:24 D
- ..; .S LRICDIEN=$P(^DGPT(IFN,70),U,LRI) D CHKICD
- ..D PTFICD^DGPTFUT(701,IFN,,.PTFICD)
- ..S J="" F S J=$O(PTFICD(J)) Q:J="" D
- ...S LRICDIEN=$P(PTFICD(J),"^",1) D CHKICD
- ...Q
- ..;SEARCH SUB FIELDS IN 501-MOVEMENTS
- ..; S LRMV=0 F S LRMV=$O(^DGPT(IFN,"M",LRMV)) Q:+LRMV'>0 D
- ..D PTFIEN^DGPTFUT(501,IFN,.LRMV)
- ..S LRMV="" F S LRMV=$O(LRMV(LRMV)) Q:LRMV="" D
- ...I $P($G(^DGPT(IFN,"M",LRMV,300)),U,3)=1 D
- ....I 'LRICDX S LRICDIEN=+$$CODEN^ICDEX("482.84 ",80) D CHKICD
- ....I LRICDX F LRXCODE="A48.1","A48.2","A48.8" D
- .....S LRICDIEN=+$$CODEN^ICDEX(LRXCODE,80) D CHKICD
- ...; I $D(^DGPT(IFN,"M",LRMV,0)) F LRI=5:1:9,11:1:15 D
- ...; .S LRICDIEN=$P(^DGPT(IFN,"M",LRMV,0),U,LRI) D CHKICD
- ...D PTFICD^DGPTFUT(501,IFN,LRMV,.PTFICD)
- ...S J="" F S J=$O(PTFICD(J)) Q:J="" D
- ....S LRICDIEN=$P(PTFICD(J),"^",1) D CHKICD
- ....Q
- K IFN,LRMV,LRICDIEN,LRI,LRXCODE
- Q
- CHKICD ;CHECK LRICDIEN CODE AND SAVE
- Q:+LRICDIEN'>0
- Q:'$D(^TMP($J,"ICD",+LRICDIEN))
- S LRPROT=$G(LRPROT,999999) S ^TMP($J,"ICDPROT",+LRICDIEN,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",+LRICDIEN,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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLREPI5 3205 printed Feb 18, 2025@23:40:08 Page 2
- LREPI5 ;DALOI/SED,WOIFO/PMK - EMERGING PATHOGENS SEARCH ;31 Dec 2014 11:03 AM
- +1 ;;5.2;LAB SERVICE;**281,315,421,442**;Sep 27, 1994;Build 15
- +2 ; Reference to ^DGPT supported by IA #418
- +3 ; Reference to DGPTFUT supported by IA #6130
- +4 ; Reference to ^ORD supported by IA #872
- +5 ; Reference to PATS^PXRMXX supported by IA #3134
- +6 ; Reference to VADPT supported by IA #10061
- +7 ; Reference to ^AUPNVPOV supported by IA #3094
- +8 ; Reference to $$CODEN^ICDEX supported by IA #5747
- +9 QUIT
- +10 ;Called from LREPI
- PTF ;SEARCH DISCHARGE DATES; NEED ADDITIONAL LATER SPECS
- +1 ; ICD array built by PTFICD^DGPTFUT
- NEW J,PTFICD
- +2 SET STDT=(LRRPS-.0001)
- SET ENDT=(LRRPE+.9999)
- +3 FOR
- SET STDT=$ORDER(^DGPT("ADS",STDT))
- if +STDT'>0!(STDT>ENDT)
- QUIT
- Begin DoDot:1
- +4 KILL LRICDX,LRCSYS
- SET LRCSYS=$$ICDSYS^LREPICD(STDT,"D")
- SET LRICDX=$SELECT(LRCSYS="ICD":0,LRCSYS="10D":1,1:-1)
- if LRICDX=-1
- QUIT
- +5 SET IFN=0
- FOR
- SET IFN=$ORDER(^DGPT("ADS",STDT,IFN))
- if +IFN'>0
- QUIT
- Begin DoDot:2
- +6 if $PIECE($GET(^DGPT(IFN,0)),U,6)'=3
- QUIT
- +7 IF $PIECE($GET(^DGPT(IFN,300)),U,3)=1
- Begin DoDot:3
- +8 IF 'LRICDX
- SET LRICDIEN=+$$CODEN^ICDEX("482.84 ",80)
- DO CHKICD
- +9 IF LRICDX
- FOR LRXCODE="A48.1","A48.2","A48.8"
- Begin DoDot:4
- +10 SET LRICDIEN=+$$CODEN^ICDEX(LRXCODE,80)
- DO CHKICD
- End DoDot:4
- End DoDot:3
- +11 ; I $D(^DGPT(IFN,70)) F LRI=10,11,16:1:24 D
- +12 ; .S LRICDIEN=$P(^DGPT(IFN,70),U,LRI) D CHKICD
- +13 DO PTFICD^DGPTFUT(701,IFN,,.PTFICD)
- +14 SET J=""
- FOR
- SET J=$ORDER(PTFICD(J))
- if J=""
- QUIT
- Begin DoDot:3
- +15 SET LRICDIEN=$PIECE(PTFICD(J),"^",1)
- DO CHKICD
- +16 QUIT
- End DoDot:3
- +17 ;SEARCH SUB FIELDS IN 501-MOVEMENTS
- +18 ; S LRMV=0 F S LRMV=$O(^DGPT(IFN,"M",LRMV)) Q:+LRMV'>0 D
- +19 DO PTFIEN^DGPTFUT(501,IFN,.LRMV)
- +20 SET LRMV=""
- FOR
- SET LRMV=$ORDER(LRMV(LRMV))
- if LRMV=""
- QUIT
- Begin DoDot:3
- +21 IF $PIECE($GET(^DGPT(IFN,"M",LRMV,300)),U,3)=1
- Begin DoDot:4
- +22 IF 'LRICDX
- SET LRICDIEN=+$$CODEN^ICDEX("482.84 ",80)
- DO CHKICD
- +23 IF LRICDX
- FOR LRXCODE="A48.1","A48.2","A48.8"
- Begin DoDot:5
- +24 SET LRICDIEN=+$$CODEN^ICDEX(LRXCODE,80)
- DO CHKICD
- End DoDot:5
- End DoDot:4
- +25 ; I $D(^DGPT(IFN,"M",LRMV,0)) F LRI=5:1:9,11:1:15 D
- +26 ; .S LRICDIEN=$P(^DGPT(IFN,"M",LRMV,0),U,LRI) D CHKICD
- +27 DO PTFICD^DGPTFUT(501,IFN,LRMV,.PTFICD)
- +28 SET J=""
- FOR
- SET J=$ORDER(PTFICD(J))
- if J=""
- QUIT
- Begin DoDot:4
- +29 SET LRICDIEN=$PIECE(PTFICD(J),"^",1)
- DO CHKICD
- +30 QUIT
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +31 KILL IFN,LRMV,LRICDIEN,LRI,LRXCODE
- +32 QUIT
- CHKICD ;CHECK LRICDIEN CODE AND SAVE
- +1 if +LRICDIEN'>0
- QUIT
- +2 if '$DATA(^TMP($JOB,"ICD",+LRICDIEN))
- QUIT
- +3 SET LRPROT=$GET(LRPROT,999999)
- SET ^TMP($JOB,"ICDPROT",+LRICDIEN,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",+LRICDIEN,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