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 Oct 16, 2024@18:15 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
