source: FOIAVistA/tag/r/LAB_SERVICE-LR-LS/LREPI5.m

Last change on this file was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 2.2 KB
Line 
1LREPI5 ;DALOI/SED-EMERGING PATHOGENS SEARCH ;10/31/02
2 ;;5.2;LAB SERVICE;**281**;Sep 27, 1994
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 Q
10 ;Called from LREPI
11PTF ;SEARCH DISCHARGE DATES; NEED ADDITIONAL LATER SPECS
12 S STDT=(LRRPS-.0001),ENDT=(LRRPE+.9999)
13 F S STDT=$O(^DGPT("ADS",STDT)) Q:+STDT'>0!(STDT>ENDT) D
14 .S IFN=0 F S IFN=$O(^DGPT("ADS",STDT,IFN)) Q:+IFN'>0 D
15 ..Q:$P($G(^DGPT(IFN,0)),U,6)'=3
16 ..I $P($G(^DGPT(IFN,300)),U,3)=1 D
17 ...S ICD9=$O(^ICD9("BA","482.80 ",0)) D ICD9
18 ..I $D(^DGPT(IFN,70)) F LRI=10,11,16:1:24 D
19 ...S ICD9=$P(^DGPT(IFN,70),U,LRI) D ICD9
20 ..;SEARCH SUB FIELDS
21 ..S LRMV=0 F S LRMV=$O(^DGPT(IFN,"M",LRMV)) Q:+LRMV'>0 D
22 ...I $P($G(^DGPT(IFN,"M",LRMV,300)),U,3)=1 D
23 ....S ICD9=$O(^ICD9("BA","482.80 ",0)) D ICD9
24 ...I $D(^DGPT(IFN,"M",LRMV,0)) F LRI=5:1:9,11:1:15 D
25 ....S ICD9=$P(^DGPT(IFN,"M",LRMV,0),U,LRI) D ICD9
26 K IFN,LRMV,ICD9,LRI
27 Q
28ICD9 ;CHECK ICD9 CODE AND SAVE
29 Q:+ICD9'>0
30 Q:'$D(^TMP($J,"ICD",+ICD9))
31 S LRPROT=$G(LRPROT,999999) S ^TMP($J,"ICDPROT",+ICD9,LRPROT)=""
32 S DFN=$P(^DGPT(IFN,0),U,1),ADMDT=$P(^DGPT(IFN,0),U,2)
33 S LRPATH=0 F S LRPATH=$O(^TMP($J,"ICD",+ICD9,LRPATH)) Q:+LRPATH'>0 D SET
34 Q
35SET ;SET THE TMP GLOBAL
36 S LRPROT=$P(^LAB(69.5,LRPATH,0),U,7)
37 S LRCHK=0 D ADDCHK Q:LRCHK
38 S:'$D(^TMP($J,LRPROT,DFN,ADMDT)) ^TMP($J,LRPROT,DFN,ADMDT)="I"_U_IFN
39 S ^TMP($J,LRPROT,DFN,ADMDT,LRPATH,(9999999-ADMDT),"PTF")=IFN
40 Q
41ADDCHK ;DO ADDITIONAL CHECKS HERE FOR AGE AND SEX SCREENING.
42 ;
43 I '$G(DFN) S DFN=$G(LRPAT)
44 K VADM
45 I $G(DFN) D DEM^VADPT
46 ;
47 I $P(^LAB(69.5,LRPATH,0),U,10)'="" D
48 .S LRSEX=$P(^LAB(69.5,LRPATH,0),U,10)
49 .I LRSEX="O"&$P(VADM(5),U,1)="M" S LRCHK=1 Q
50 .I LRSEX="O"&$P(VADM(5),U,1)="F" S LRCHK=1 Q
51 .I LRSEX'=$P(VADM(5),U,1) S LRCHK=1
52 I $P(^LAB(69.5,LRPATH,0),U,11)'=""!$P(^LAB(69.5,LRPATH,0),U,12)'="" D
53 .S LRBEF=$P(^LAB(69.5,LRPATH,0),U,11),LRAFT=$P(^LAB(69.5,LRPATH,0),U,12)
54 .I LRBEF'=""&($P(VADM(3),U,1)>LRBEF) S LRCHK=1
55 .I LRAFT'=""&($P(VADM(3),U,1)<LRAFT) S LRCHK=1
56 K LRBEF,LRSEX,LRAFT,VADM
57 Q
Note: See TracBrowser for help on using the repository browser.