source: WorldVistAEHR/trunk/r/ICR_IMMUNOLOGY_CASE_REGISTRY-IMR/IMRCDC.m@ 1096

Last change on this file since 1096 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 4.3 KB
Line 
1IMRCDC ;ISC-SF/JLI-CDC DATA ;6/13/95 10:22
2 ;;2.1;IMMUNOLOGY CASE REGISTRY;;Feb 09, 1998
3ENT ; Is ENT code ever used?
4 S IMRPT=0 F IMRI=0:0 S IMRPT=$O(^IMR(158,"AC",4,IMRPT)) Q:IMRPT="" I $D(^IMR(158,IMRPT,0)),$P(^(0),U,23)'="",$P(^(0),U,39)="" D S1 S $P(^IMR(158,IMRPT,0),U,39)="C" S:$P(^(0),U,41)="" $P(^(0),U,41)=IMRIP D ST
5END ; called from IMRCDCPR
6 K IMRBDT,IMRCDT,IMRCK,IMRCNT,IMRDT,IMRI,IMRIP,IMRJ,IMRLAB,IMRP0,IMRP1,IMRP2,IMRP3,IMRP4,IMRP5,IMRP6,IMRP7
7 Q
8ST ; called from ENT. Is this code used?
9 S:'$D(^IMR(159,1,7,0)) ^(0)="^159.06P^^"
10 I '$D(^IMR(159,1,7,"B",IMRPT)) S IMRCNT=$P(^IMR(159,1,7,0),U,3),IMRCNT=IMRCNT+1,$P(^(0),U,3)=IMRCNT,$P(^(0),U,4)=$P(^(0),U,4)+1,^IMR(159,1,7,IMRCNT,0)=IMRPT_"^"_IMRCDT,^IMR(159,1,7,"B",IMRPT,IMRCNT)="",$P(^IMR(159,1,0),U,3)=IMRPT Q
11 I $D(^IMR(159,1,7,"B",IMRPT)) S IMRCNT=$O(^IMR(159,1,7,"B",IMRPT)) Q:IMRCNT="" I $D(^IMR(159,1,7,IMRCNT,0)) S $P(^(0),U,2)=IMRCDT
12 Q
13S1 ; called from IMRCDCPR
14 S (IMRIP,IMRP0,IMRP1,IMRP2,IMRP3,IMRP4,IMRP5,IMRP6,IMRP7)="" S (IMRBDT,IMRCK)=0 Q:IMRPT=""!('$D(^IMR(158,IMRPT,0))) S IMRP0=^(0) S:'$D(^IMR(158,IMRPT,1)) ^(1)="^" S IMRP1=^(1) S IMRCDT=$P(IMRP1,U,6) S:IMRCDT="" IMRCDT=DT
15 S $P(^IMR(158,IMRPT,1),U,6)=IMRCDT Q:$P(IMRP1,U,5)="Y" S:'$D(^IMR(158,IMRPT,2)) ^(2)="^" S IMRP2=^(2) S IMRP4=$S($D(^IMR(158,IMRPT,4)):^(4),1:""),IMRP5=$S($D(^IMR(158,IMRPT,5)):^(5),1:"")
16 S IMRX1=$S($P(IMRP0,U,35):$P(IMRP0,U,35),1:$P(IMRP0,U,23)) ;calculate Age at AIDS Diagnosis. Used Cat 3 date first if it exists.
17 S IMRX2=$P(VADM(3),U) ;date of birth
18 S IMRAAAD=$$AGE^IMRUTL(IMRX1,IMRX2) ;calculate age at aids dx
19 S:IMRAAAD>0 $P(^IMR(158,IMRPT,2),U,16)=IMRAAAD ;store age if >0
20 K IMRAAAD,IMRX1,IMRX2
21 S:$P(IMRP1,U,34)="" $P(^IMR(158,IMRPT,1),U,34)=$S($P(IMRP5,U,19)'="":$P(^(1),U,34)=2,1:1) S:$P(IMRP2,U,21)="" $P(^IMR(158,IMRPT,2),U,21)=9
22 S:$P(IMRP2,U,23)="" $P(^IMR(158,IMRPT,2),U,23)=9 S:$P(IMRP2,U,53)="" $P(^IMR(158,IMRPT,2),U,53)=9 S:$P(IMRP1,U,26)="" $P(^IMR(158,IMRPT,1),U,26)=9 S:$P(IMRP1,U,28)="" $P(^IMR(158,IMRPT,1),U,28)=9
23 S IMRLAB=$P(VADM(5),U)="M" S:IMRLAB $P(^IMR(158,IMRPT,1),U,29)="" I 'IMRLAB S:$P(IMRP1,U,29)="" $P(^IMR(158,IMRPT,1),U,29)=9
24 S:$P(IMRP1,U,30)="" $P(^IMR(158,IMRPT,1),U,30)=9 S:$P(IMRP1,U,31)="" $P(^IMR(158,IMRPT,1),U,31)=9 S:$P(IMRP1,U,32)="" $P(^IMR(158,IMRPT,1),U,32)=9
25 S:$P(IMRP1,U,33)="" $P(^IMR(158,IMRPT,1),U,33)=9 S:$P(IMRP1,U,21)="" $P(^IMR(158,IMRPT,1),U,21)=9 S:$P(IMRP1,U,24)="" $P(^IMR(158,IMRPT,1),U,24)=9
26 S IMRCK=$P(IMRP2,U,4) S:IMRCK>0 $P(^IMR(158,IMRPT,2),U,24)="D" D:IMRCK>0 CK S IMRCK=$P(IMRP4,U,17) S:IMRCK>0 $P(^(2),U,25)="P" D:IMRCK>0 CK S IMRCK=$P(IMRP4,U,24) S:IMRCK>0 $P(^(2),U,26)="D" D:IMRCK>0 CK
27 S IMRCK=$P(IMRP4,U,23) S:IMRCK>0 $P(^IMR(158,IMRPT,2),U,27)="D" D:IMRCK>0 CK S IMRCK=$P(IMRP4,U,19) S:IMRCK>0 $P(^(2),U,28)="P" D:IMRCK>0 CK S IMRCK=$P(IMRP5,U,6) S:IMRCK>0 $P(^(2),U,29)="D" D:IMRCK>0 CK
28 S IMRCK=$P(IMRP2,U,8) S:IMRCK>0 $P(^IMR(158,IMRPT,2),U,30)="D" D:IMRCK>0 CK S IMRCK=$P(IMRP5,U,3) S:IMRCK>0 $P(^(2),U,31)="D" D:IMRCK>0 CK
29 S IMRCK=$S($P(IMRP4,U,1)'="":$P(IMRP4,U,1),$P(IMRP4,U,2)'="":$P(IMRP4,U,2),$P(IMRP4,U,3)'="":$P(IMRP4,U,3),1:"") S:IMRCK>0 $P(^IMR(158,IMRPT,2),U,32)="D" D:IMRCK>0 CK
30 S IMRCK=$P(IMRP4,U,25) S:IMRCK>0 $P(^IMR(158,IMRPT,2),U,33)="D" D:IMRCK>0 CK S IMRCK=$P(IMRP2,U,9) S:IMRCK>0 $P(^(2),U,34)="D" D:IMRCK>0 CK S IMRCK=$P(IMRP4,U,30) S:IMRCK>0 $P(^(2),U,35)="D" D:IMRCK>0 CK
31 S IMRCK=$P(IMRP2,U,6) S:IMRCK>0 $P(^IMR(158,IMRPT,2),U,36)="D" D:IMRCK>0 CK S IMRCK=$P(IMRP2,U,7) S:IMRCK>0 $P(^(2),U,37)="D" D:IMRCK>0 CK S IMRCK=$P(IMRP5,U,2) S:IMRCK>0 $P(^(2),U,38)="D" D:IMRCK>0 CK
32 S IMRCK=$S($P(IMRP4,U,28)'="":$P(IMRP4,U,28),$P(IMRP4,U,29)'="":$P(IMRP4,U,29),1:"") S:IMRCK>0 $P(^IMR(158,IMRPT,2),U,39)="D" D:IMRCK>0 CK S IMRCK=$P(IMRP4,U,27) S:IMRCK>0 $P(^(2),U,40)="D" D:IMRCK>0 CK
33 S IMRCK=$P(IMRP2,U,5) S:IMRCK>0 $P(^IMR(158,IMRPT,2),U,41)="D" D:IMRCK>0 CK S IMRCK=$P(IMRP4,U,22) S:IMRCK>0 $P(^(2),U,42)="D" D:IMRCK>0 CK S IMRCK=$P(IMRP5,U,5) S:IMRCK>0 $P(^(2),U,43)="D" D:IMRCK>0 CK
34 S IMRCK=$P(IMRP5,U,8) S:IMRCK>0 $P(^IMR(158,IMRPT,2),U,44)="D" D:IMRCK>0 CK S IMRCK=$P(IMRP4,U,21) S:IMRCK>0 $P(^(2),U,45)="D" D:IMRCK>0 CK S IMRCK=$P(IMRP5,U,7) S:IMRCK>0 $P(^(2),U,46)="D" D:IMRCK>0 CK S:IMRCK>0 $P(^(2),U,47)=IMRBDT
35 S $P(^IMR(158,IMRPT,2),U,51)=$S($P(IMRP5,U,17)'=""!($P(IMRP5,U,18)'="")!($P(IMRP5,U,20)'=""):"Y",1:"U")
36S2 S IMRDT=0 S (IMRLAB(1),IMRLAB(2),IMRLAB(3))=""
37 Q
38CK S:IMRBDT=0&(IMRCK>0) IMRBDT=IMRCK S:IMRCK<IMRBDT IMRBDT=IMRCK S IMRCK=0 Q
Note: See TracBrowser for help on using the repository browser.