source: FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMCWH.m@ 794

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

initial load of FOIAVistA 6/30/08 version

File size: 6.2 KB
Line 
1PXRMCWH ; SLC/AGP - Computed findings for WH project. ;06/09/2006
2 ;;2.0;CLINICAL REMINDERS;**1,4**;Feb 4, 2005;Build 21
3 ;
4MAM(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;Computed finding for
5 ;mammogram screening and review
6 ;
7 N CNT,CNT1,RESULT,WHDATE
8 S NGET=$S(NGET<0:-NGET,1:NGET)
9 S (CNT1,CNT,NFOUND)=0,DATE=$$NOW^PXRMDATE,TEST(1)=0
10 I $G(BDT)'="",$G(EDT)'="" S WHDATE=BDT_U_EDT
11 D LATEST^WVRPCPR(.RESULT,DFN,"M",$G(WHDATE),$G(NGET),"*")
12 I $D(RESULT)>0 D PROCESS(.RESULT,.CNT1,.TEST,.DATA,.TEXT,NGET,BDT,EDT,NFOUND)
13 I $G(CNT1)>0 S NFOUND=CNT1
14 Q
15 ;
16MAMA(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;Computed finding for
17 ;mammogram abnormal result
18 ;
19 N CNT,CNT1,RESULT,WHDATE
20 S NGET=$S(NGET<0:-NGET,1:NGET)
21 S (CNT1,CNT,NFOUND)=0,DATE=$$NOW^PXRMDATE,TEST(1)=0
22 I $G(BDT)'="",$G(EDT)'="" S WHDATE=BDT_U_EDT
23 D LATEST^WVRPCPR(.RESULT,DFN,"M",$G(WHDATE),$G(NGET),"A")
24 I $D(RESULT)>0 D PROCESS(.RESULT,.CNT1,.TEST,.DATA,.TEXT,NGET,BDT,EDT,NFOUND)
25 I $G(CNT1)>0 S NFOUND=CNT1
26 Q
27 ;
28PAP(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;Computed
29 ;finding for pap smear screening and review
30 ;
31 N CNT,CNT1,RESULT,WHDATE
32 S NGET=$S(NGET<0:-NGET,1:NGET)
33 S (CNT1,CNT,NFOUND)=0,DATE=$$NOW^PXRMDATE,TEST(1)=0
34 I $G(BDT)'="",$G(EDT)'="" S WHDATE=BDT_U_EDT
35 D LATEST^WVRPCPR(.RESULT,DFN,"P",$G(WHDATE),$G(NGET),"*")
36 I $D(RESULT)>0 D PROCESS(.RESULT,.CNT1,.TEST,.DATA,.TEXT,NGET,BDT,EDT,NFOUND)
37 I $G(CNT1)>0 S NFOUND=CNT1
38 Q
39 ;
40 ;
41PAPA(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;Computed finding for
42 ;pap smear abnormal result
43 ;
44 N CNT,CNT1,RESULT,WHDATE
45 S NGET=$S(NGET<0:-NGET,1:NGET)
46 S (CNT1,CNT,NFOUND)=0,DATE=$$NOW^PXRMDATE,TEST(1)=0
47 I $G(BDT)'="",$G(EDT)'="" S WHDATE=BDT_U_EDT
48 D LATEST^WVRPCPR(.RESULT,DFN,"P",$G(WHDATE),$G(NGET),"A")
49 I $D(RESULT)>0 D PROCESS(.RESULT,.CNT1,.TEST,.DATA,.TEXT,NGET,BDT,EDT,NFOUND)
50 I $G(CNT1)>0 S NFOUND=CNT1
51 Q
52 ;
53 ;
54PROCESS(RESULT,CNT1,TEST,DATA,TEXT,NGET,BDT,EDT,NFOUND) ;
55 ;Pieces out data in Result for Reminder evaluation
56 N DATE1
57 I $P($G(RESULT(0)),U)<0 Q
58 F S CNT=$O(RESULT(CNT)) Q:CNT=""!(CNT1>$G(NGET)) I CNT'=0 D
59 . S DATE1=$P($G(RESULT(CNT)),U,3)
60 . I $G(BDT)'="",$G(EDT)'="",EDT<BDT Q
61 . S CNT1=CNT1+1
62 . S TEST(CNT1)=0
63 . S DATA(CNT1,"LINK")=$P($G(RESULT(CNT)),U,7)
64 . S DATA(CNT1,"STATUS")=$P($G(RESULT(CNT)),U,8)
65 . S DATA(CNT1,"VALUE")=$P($G(RESULT(CNT)),U,5)
66 . S DATA(CNT1,"WVIEN")=$P($G(RESULT(CNT)),U)
67 . S TEST(CNT1)=1,DATE(CNT1)=$G(DATE1)
68 . S TEXT(CNT1)=$P($G(RESULT(CNT)),U,4)_" "_$P($G(RESULT(CNT)),U,6)
69 . ;S VALUE(CNT1)=$P($G(RESULT(CNT)),U,5)
70 Q
71 ;
72PAPSCR(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;Computed finding for
73 ;pap smear screening and f/u
74 ;
75 N CNT,CNT1,CNT2,DATE1,DS,EDTT,IND,JND,MOR,MORIEN,NODE,OD
76 N PXRMWVT,PXRMWVM
77 N SDIR,SNOWCNT,TDATA,TDATE,TOP,TTEST,TTEXT,SNOWTOP,NODE,WVPAP
78 N DAS,DAS0,DAS1,DAS2,DAS3,DAS4,DAS5
79 S NFOUND=0
80 S WVPAP=$O(^WV(790.2,"B","PAP SMEAR",""))
81 S SNOWCNT=0,CNT=0
82 ;Get SNOMED Morphology codes from file 790.2
83 F S SNOWCNT=$O(^WV(790.2,WVPAP,1,SNOWCNT)) Q:+SNOWCNT'>0 D
84 .S PXRMWVM($P($G(^WV(790.2,WVPAP,1,SNOWCNT,0)),U))=$P($G(^WV(790.2,WVPAP,1,SNOWCNT,0)),U,2)
85 ;
86 ;Get SNOMED Topography codes from file 790.2
87 S SNOWCNT=0 F S SNOWCNT=$O(^WV(790.2,WVPAP,2,SNOWCNT)) Q:+SNOWCNT'>0 D
88 .S PXRMWVT($P($G(^WV(790.2,WVPAP,2,SNOWCNT,0)),U))=""
89 ;
90 ;If no topography codes quit
91 I $D(PXRMWVT)'>0 S DATA(1,"VALUE")="NO TOPOGRAPHY CODES FOUND",TEST(1)=0,TEXT(1)=" " Q
92 ;
93 ;Handle search direction and date ranges
94 S EDTT=$S(EDT[".":EDT+.0000001,1:EDT+.240001)
95 S SDIR=$S(NGET<0:+1,1:-1)
96 S DS=$S(SDIR=+1:BDT-.000001,1:EDTT)
97 S NGET=$S(NGET<0:-NGET,1:NGET)
98 ;
99 ;Match Topography codes in PXRMINDX for Lab
100 N DTARRAY,NODE1,TCNT,ODATE1
101 S TOP=0,CNT1=0,TCNT=0,ODATE1=0 F S TOP=$O(PXRMWVT(TOP)) Q:+TOP'>0!(CNT1=NGET) D
102 .S SNOWTOP="A;O;"_TOP,DATE1=DS
103 .F S DATE1=+$O(^PXRMINDX(63,"PI",DFN,SNOWTOP,DATE1),SDIR) Q:$S(DATE1'>0:1,DATE1<BDT:1,DATE1>EDTT:1,1:0) D
104 ..S DAS=$O(^PXRMINDX(63,"PI",DFN,SNOWTOP,DATE1,""))
105 ..;
106 ..;set date to dtarray to hanle multiple snomed done on the same date
107 ..S DTARRAY(DATE1)=$S($D(DTARRAY(DATE1)):DTARRAY(DATE1)+1,1:1)
108 ..S DTARRAY(DATE1,DTARRAY(DATE1))=TOP_U_DAS
109 ;
110 ;loop through date array
111 N DAS
112 S DATE1=DS F S DATE1=$O(DTARRAY(DATE1),SDIR) Q:$S(DATE1'>0:1,CNT1=NGET:1,1:0) D
113 .S TCNT=0,CNT1=CNT1+1 F S TCNT=$O(DTARRAY(DATE1,TCNT)) Q:TCNT'>0 D
114 ..S NODE1=$G(DTARRAY(DATE1,TCNT))
115 ..S TDATE(CNT1)=DATE1,NODE=$G(^LAB(61,$P(NODE1,U),0)),DAS=$P(NODE1,U,2)
116 ..S TTEST(CNT1)=0
117 ..;
118 ..;set TDATA to value
119 ..S TDATA(CNT1,"SNOMED",TCNT,"VALUE")="T-"_$P(NODE,U,2)_" "_$P(NODE,U)
120 ..I '$D(TTEXT(CNT1)) S TTEXT(CNT1)=TDATA(CNT1,"SNOMED",TCNT,"VALUE")_" - "
121 ..E I $L(TTEXT(CNT1))+$L(TDATA(CNT1,"SNOMED",TCNT,"VALUE"))<255 D
122 ...I $E(TTEXT(CNT1),$L(TTEXT(CNT1)))="\" S TTEXT(CNT1)=TTEXT(CNT1)_TDATA(CNT1,"SNOMED",TCNT,"VALUE")_" - "
123 ..S TDATA(CNT1,"SNOMED",TCNT,"TOPH")="T-"_$P(NODE,U,2)
124 ..;
125 ..;Dig down into Lab file to find a match for morphology codes
126 ..S SNOWCNT=0,DAS0=$P($G(DAS),";"),DAS1=$P($G(DAS),";",3)
127 ..S DAS2=$P(DAS,";",4),DAS3=$P(DAS,";",5)
128 ..S CNT2=0,NODE=""
129 ..;
130 ..;get Morphology results
131 ..N MCNT S MCNT=0
132 ..S TDATA(CNT1,"UNSATISFACTORY")="F"
133 ..F S SNOWCNT=$O(^LR(DAS0,"CY",DAS1,DAS2,DAS3,2,SNOWCNT)) Q:+SNOWCNT'>0 D
134 ...S MORIEN=^LR(DAS0,"CY",DAS1,DAS2,DAS3,2,SNOWCNT,0)
135 ...I $D(PXRMWVM(MORIEN))>0 D
136 ....S TTEST(CNT1)=1,MCNT=MCNT+1
137 ....;
138 ....;handle multiple SNOMED entries for the same date
139 ....S NODE=^LAB(61.1,MORIEN,0)
140 ....N STR
141 ....I '$D(TTEXT(CNT1)) S TTEXT(CNT1)="M-"_$P(NODE,U,2)_" "_$P(NODE,U)
142 ....E D
143 .....S STR="M-"_$P(NODE,U,2)_" "_$P(NODE,U)
144 .....I $L(TTEXT(CNT1))+STR'<255 Q
145 .....S TTEXT(CNT1)=TTEXT(CNT1)_STR_";"
146 ....;
147 ....S TDATA(CNT1,"SNOMED",TCNT,MCNT,"MORP")="M-"_$P(NODE,U,2)
148 ....S TDATA(CNT1,"SNOMED",TCNT,MCNT,"RESULT STATUS")=$S(PXRMWVM(MORIEN)="0":"NEM",PXRMWVM(MORIEN)="1":"Abnormal",PXRMWVM(MORIEN)="2":"Unsatisfactory",1:"Unknown")
149 ....I TDATA(CNT1,"SNOMED",TCNT,MCNT,"RESULT STATUS")["Un" S TDATA(CNT1,"UNSATISFACTORY")="T"
150 ....I $L(TTEXT(CNT1))+$L("\\")<255 S TTEXT(CNT1)=TTEXT(CNT1)_"\\"
151 S NFOUND=CNT1
152 N DATE1,CNT,TCNT
153 F IND=1:1:NFOUND S OD(TDATE(IND),IND)=""
154 S CNT1=0,IND=""
155 F S IND=$O(OD(IND),SDIR) Q:IND="" D
156 . S JND=0
157 . F S JND=$O(OD(IND,JND)) Q:JND="" D
158 .. S CNT1=CNT1+1
159 .. S DATE(CNT1)=IND
160 .. S TEST(CNT1)=TTEST(JND)
161 .. M DATA(CNT1)=TDATA(JND)
162 .. S TEXT(CNT1)=TTEXT(JND)
163 Q
164 ;
Note: See TracBrowser for help on using the repository browser.