Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LREPI5

LREPI5.m

Go to the documentation of this file.
  1. 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
  1. ; Reference to ^DGPT supported by IA #418
  1. ; Reference to DGPTFUT supported by IA #6130
  1. ; Reference to ^ORD supported by IA #872
  1. ; Reference to PATS^PXRMXX supported by IA #3134
  1. ; Reference to VADPT supported by IA #10061
  1. ; Reference to ^AUPNVPOV supported by IA #3094
  1. ; Reference to $$CODEN^ICDEX supported by IA #5747
  1. Q
  1. ;Called from LREPI
  1. PTF ;SEARCH DISCHARGE DATES; NEED ADDITIONAL LATER SPECS
  1. N J,PTFICD ; ICD array built by PTFICD^DGPTFUT
  1. S STDT=(LRRPS-.0001),ENDT=(LRRPE+.9999)
  1. F S STDT=$O(^DGPT("ADS",STDT)) Q:+STDT'>0!(STDT>ENDT) D
  1. .K LRICDX,LRCSYS S LRCSYS=$$ICDSYS^LREPICD(STDT,"D"),LRICDX=$S(LRCSYS="ICD":0,LRCSYS="10D":1,1:-1) Q:LRICDX=-1
  1. .S IFN=0 F S IFN=$O(^DGPT("ADS",STDT,IFN)) Q:+IFN'>0 D
  1. ..Q:$P($G(^DGPT(IFN,0)),U,6)'=3
  1. ..I $P($G(^DGPT(IFN,300)),U,3)=1 D
  1. ...I 'LRICDX S LRICDIEN=+$$CODEN^ICDEX("482.84 ",80) D CHKICD
  1. ...I LRICDX F LRXCODE="A48.1","A48.2","A48.8" D
  1. ....S LRICDIEN=+$$CODEN^ICDEX(LRXCODE,80) D CHKICD
  1. ..; I $D(^DGPT(IFN,70)) F LRI=10,11,16:1:24 D
  1. ..; .S LRICDIEN=$P(^DGPT(IFN,70),U,LRI) D CHKICD
  1. ..D PTFICD^DGPTFUT(701,IFN,,.PTFICD)
  1. ..S J="" F S J=$O(PTFICD(J)) Q:J="" D
  1. ...S LRICDIEN=$P(PTFICD(J),"^",1) D CHKICD
  1. ...Q
  1. ..;SEARCH SUB FIELDS IN 501-MOVEMENTS
  1. ..; S LRMV=0 F S LRMV=$O(^DGPT(IFN,"M",LRMV)) Q:+LRMV'>0 D
  1. ..D PTFIEN^DGPTFUT(501,IFN,.LRMV)
  1. ..S LRMV="" F S LRMV=$O(LRMV(LRMV)) Q:LRMV="" D
  1. ...I $P($G(^DGPT(IFN,"M",LRMV,300)),U,3)=1 D
  1. ....I 'LRICDX S LRICDIEN=+$$CODEN^ICDEX("482.84 ",80) D CHKICD
  1. ....I LRICDX F LRXCODE="A48.1","A48.2","A48.8" D
  1. .....S LRICDIEN=+$$CODEN^ICDEX(LRXCODE,80) D CHKICD
  1. ...; I $D(^DGPT(IFN,"M",LRMV,0)) F LRI=5:1:9,11:1:15 D
  1. ...; .S LRICDIEN=$P(^DGPT(IFN,"M",LRMV,0),U,LRI) D CHKICD
  1. ...D PTFICD^DGPTFUT(501,IFN,LRMV,.PTFICD)
  1. ...S J="" F S J=$O(PTFICD(J)) Q:J="" D
  1. ....S LRICDIEN=$P(PTFICD(J),"^",1) D CHKICD
  1. ....Q
  1. K IFN,LRMV,LRICDIEN,LRI,LRXCODE
  1. Q
  1. CHKICD ;CHECK LRICDIEN CODE AND SAVE
  1. Q:+LRICDIEN'>0
  1. Q:'$D(^TMP($J,"ICD",+LRICDIEN))
  1. S LRPROT=$G(LRPROT,999999) S ^TMP($J,"ICDPROT",+LRICDIEN,LRPROT)=""
  1. S DFN=$P(^DGPT(IFN,0),U,1),ADMDT=$P(^DGPT(IFN,0),U,2)
  1. S LRPATH=0 F S LRPATH=$O(^TMP($J,"ICD",+LRICDIEN,LRPATH)) Q:+LRPATH'>0 D SET
  1. Q
  1. SET ;SET THE TMP GLOBAL
  1. S LRPROT=$P(^LAB(69.5,LRPATH,0),U,7)
  1. S LRCHK=0 D ADDCHK Q:LRCHK
  1. S:'$D(^TMP($J,LRPROT,DFN,ADMDT)) ^TMP($J,LRPROT,DFN,ADMDT)="I"_U_IFN
  1. S ^TMP($J,LRPROT,DFN,ADMDT,LRPATH,(9999999-ADMDT),"PTF")=IFN
  1. Q
  1. ADDCHK ;DO ADDITIONAL CHECKS HERE FOR AGE AND SEX SCREENING.
  1. ;
  1. I '$G(DFN) S DFN=$G(LRPAT)
  1. K VADM
  1. I $G(DFN) D DEM^VADPT
  1. ;
  1. I $P(^LAB(69.5,LRPATH,0),U,10)'="" D
  1. .S LRSEX=$P(^LAB(69.5,LRPATH,0),U,10)
  1. .I LRSEX="O"&$P(VADM(5),U,1)="M" S LRCHK=1 Q
  1. .I LRSEX="O"&$P(VADM(5),U,1)="F" S LRCHK=1 Q
  1. .I LRSEX'=$P(VADM(5),U,1) S LRCHK=1
  1. I $P(^LAB(69.5,LRPATH,0),U,11)'=""!$P(^LAB(69.5,LRPATH,0),U,12)'="" D
  1. .S LRBEF=$P(^LAB(69.5,LRPATH,0),U,11),LRAFT=$P(^LAB(69.5,LRPATH,0),U,12)
  1. .I LRBEF'=""&($P(VADM(3),U,1)>LRBEF) S LRCHK=1
  1. .I LRAFT'=""&($P(VADM(3),U,1)<LRAFT) S LRCHK=1
  1. K LRBEF,LRSEX,LRAFT,VADM
  1. Q