source: FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMINDX.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 6.5 KB
Line 
1PXRMINDX ; SLC/PKR - Routines for utilizing the index. ;10/11/2007
2 ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
3 ;Code for patient findings.
4 ;================================================================
5EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;General finding evaluator.
6 N BDT,EDT,FIEVT,FILENUM,FINDING,FINDPA,ITEM,NOINDEX
7 S FILENUM=$$GETFNUM^PXRMDATA(ENODE)
8 I $G(^PXRMINDX(FILENUM,"DATE BUILT"))="" D
9 . D NOINDEX^PXRMERRH("D",PXRMITEM,FILENUM)
10 . S NOINDEX=1
11 E S NOINDEX=0
12 S ITEM=""
13 F S ITEM=$O(DEFARR("E",ENODE,ITEM)) Q:ITEM="" D
14 . S FINDING=""
15 . F S FINDING=$O(DEFARR("E",ENODE,ITEM,FINDING)) Q:+FINDING=0 D
16 .. I NOINDEX S FIEVAL(FINDING)=0 Q
17 .. K FINDPA
18 .. M FINDPA=DEFARR(20,FINDING)
19 .. K FIEVT
20 .. D FIEVAL(FILENUM,"PI",DFN,ITEM,.FINDPA,.FIEVT)
21 .. M FIEVAL(FINDING)=FIEVT
22 .. S FIEVAL(FINDING,"FINDING")=$P(FINDPA(0),U,1)
23 Q
24 ;
25 ;================================================================
26EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL) ;General term
27 ;evaluator.
28 N FIEVT,FILENUM,ITEM,NOINDEX,PFINDPA
29 N TFINDING,TFINDPA
30 S FILENUM=$$GETFNUM^PXRMDATA(ENODE)
31 I $G(^PXRMINDX(FILENUM,"DATE BUILT"))="" D
32 . D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),FILENUM)
33 . S NOINDEX=1
34 E S NOINDEX=0
35 S ITEM=""
36 F S ITEM=$O(TERMARR("E",ENODE,ITEM)) Q:+ITEM=0 D
37 . S TFINDING=""
38 . F S TFINDING=$O(TERMARR("E",ENODE,ITEM,TFINDING)) Q:+TFINDING=0 D
39 .. I NOINDEX S TFIEVAL(TFINDING)=0 Q
40 .. K FIEVT,PFINDPA,TFINDPA
41 .. M TFINDPA=TERMARR(20,TFINDING)
42 ..;Set the finding parameters.
43 .. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
44 .. D FIEVAL(FILENUM,"PI",DFN,ITEM,.PFINDPA,.FIEVT)
45 .. M TFIEVAL(TFINDING)=FIEVT
46 .. S TFIEVAL(TFINDING,"FINDING")=$P(TFINDPA(0),U,1)
47 Q
48 ;
49 ;================================================================
50FIEVAL(FILENUM,SNODE,DFN,ITEM,PFINDPA,FIEVAL) ;
51 ;Evaluate regular patient findings.
52 N BDT,CASESEN,COND,CONVAL,DAS,DATE,EDT,FIEVD,FLIST,ICOND,IEN,IND,INVFD
53 N NFOUND,NGET,NOCC,NP
54 N SAVE,SDIR,SSFIND,STATOK,STATUSA,UCIFS,USESTRT,VSLIST
55 ;Set the finding search parameters.
56 D SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT)
57 D SCPAR^PXRMCOND(.PFINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST)
58 S SDIR=$S(NOCC<0:+1,1:-1)
59 S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
60 S NGET=$S(UCIFS:50,1:NOCC)
61 ;Determine if this is a finding with a start and stop date.
62 S SSFIND=$S(FILENUM=52:1,FILENUM["55":1,FILENUM=100:1,1:0)
63 S USESTRT=$S(SSFIND:$P(PFINDPA(0),U,15),1:0)
64 I FILENUM=100,USESTRT="" S USESTRT=1
65 ;Get the status list.
66 D GETSTATI^PXRMSTAT(FILENUM,.PFINDPA,.STATUSA)
67 I SSFIND D FPDATSS(FILENUM,SNODE,DFN,ITEM,NGET,SDIR,BDT,EDT,USESTRT,.NFOUND,.FLIST)
68 I 'SSFIND D FPDAT(FILENUM,SNODE,DFN,ITEM,NGET,SDIR,BDT,EDT,.NFOUND,.FLIST)
69 I NFOUND=0 S FIEVAL=0 Q
70 S INVFD=$P(PFINDPA(0),U,16)
71 S NP=0
72 F IND=1:1:NFOUND Q:NP=NOCC D
73 . S DAS=$P(FLIST(IND),U,1)
74 .;If this a Lab finding attach the item to the DAS.
75 . I PFINDPA(0)["LAB(60" S DAS=ITEM_"~"_DAS
76 .;If this is a Mental Health finding attach the scale to DAS.
77 . I PFINDPA(0)["YTT(601.71" S DAS=DAS_"S"_$P(PFINDPA(0),U,12)
78 . D GETDATA^PXRMDATA(FILENUM,DAS,.FIEVD)
79 . I INVFD D GETDATA^PXRMVSIT(FIEVD("VISIT"),.FIEVD,0)
80 .;If there is a status list make sure the finding has one on the list.
81 . S STATOK=$S($D(STATUSA):$$STATUSOK(.STATUSA,.FIEVD),1:1)
82 . I 'STATOK Q
83 . S CONVAL=$S(COND'="":$$COND^PXRMCOND(CASESEN,ICOND,VSLIST,.FIEVD),1:1)
84 . S SAVE=$S('UCIFS:1,(UCIFS&CONVAL):1,1:0)
85 . I SAVE D
86 .. S NP=NP+1
87 .. S FIEVAL(NP)=CONVAL
88 .. I COND'="" S FIEVAL(NP,"CONDITION")=CONVAL
89 .. S FIEVAL(NP,"DAS")=$P(FLIST(IND),U,1)
90 .. S FIEVAL(NP,"DATE")=$P(FLIST(IND),U,2)
91 .. M FIEVAL(NP)=FIEVD
92 .. I $G(PXRMDEBG) M FIEVAL(NP,"CSUB")=FIEVD
93 ;
94 ;Save the finding result.
95 D SFRES^PXRMUTIL(SDIR,NP,.FIEVAL)
96 S FIEVAL("FILE NUMBER")=FILENUM
97 Q
98 ;
99 ;================================================================
100FPDAT(FILENUM,SNODE,DFN,ITEM,NGET,SDIR,BDT,EDT,NFOUND,FLIST) ;Find patient
101 ;data for regular files. FLIST is returned in date order, i.e.,
102 ;FLIST(1) is the most recent SDIR=-1, oldest SDIR=+1.
103 I FILENUM=601.84 D SEVALFI^PXRMMH(DFN,ITEM,NGET,SDIR,BDT,EDT,.NFOUND,.FLIST) Q
104 N DAS,DATE,DONE,EDTT
105 S EDTT=$S(EDT[".":EDT+.0000001,1:EDT+.240001)
106 S (DONE,NFOUND)=0
107 S DATE=$S(SDIR=+1:BDT-.000001,1:EDTT)
108 F S DATE=+$O(^PXRMINDX(FILENUM,SNODE,DFN,ITEM,DATE),SDIR) Q:(DATE=0)!(DONE) D
109 . I DATE<BDT,SDIR=-1 S DONE=1 Q
110 . I DATE>EDTT,SDIR=1 S DONE=1 Q
111 . S DAS=$O(^PXRMINDX(FILENUM,SNODE,DFN,ITEM,DATE,""))
112 . S NFOUND=NFOUND+1
113 . S FLIST(NFOUND)=DAS_U_DATE
114 . I NFOUND=NGET S DONE=1 Q
115 Q
116 ;
117 ;================================================================
118FPDATSS(FILENUM,SNODE,DFN,ITEM,NGET,SDIR,BDT,EDT,USESTRT,NFOUND,FLIST) ;Find
119 ;patient data for findings that have a start and stop date. FLIST
120 ;is returned in date order, i.e., FLIST(1) is the most recent.
121 N DAS,DONE,EDTT,OVERLAP,SDATE,START,STOP,TDATE,TIND,TLIST
122 S EDTT=$S(EDT[".":EDT+.0000001,1:EDT+.240001)
123 S (DONE,NFOUND)=0
124 S START=$S(SDIR=+1:0,1:EDTT)
125 F S START=+$O(^PXRMINDX(FILENUM,SNODE,DFN,ITEM,START),SDIR) Q:(START=0)!(DONE)!(START>EDTT) D
126 . S STOP=""
127 . F S STOP=$O(^PXRMINDX(FILENUM,SNODE,DFN,ITEM,START,STOP),SDIR) Q:(STOP="")!(DONE) D
128 ..;Items that do not have a stop date are flagged by "U".
129 .. S SDATE=$S(USESTRT:START,STOP["U":$$NOW^PXRMDATE_"U",1:STOP)
130 .. S OVERLAP=$$OVERLAP(START,SDATE,BDT,EDT)
131 .. I OVERLAP="O" D
132 ... S DAS=$O(^PXRMINDX(FILENUM,SNODE,DFN,ITEM,START,STOP,""))
133 ... S NFOUND=NFOUND+1,TLIST(SDATE,NFOUND)=DAS_U_SDATE
134 ..;Some orders and non-VA meds may not have a Stop Date so we have
135 ..;to check all entries.
136 .. I FILENUM="55NVA" Q
137 .. I FILENUM=100 Q
138 .. I OVERLAP="L",SDIR=-1 S DONE=1 Q
139 .. I OVERLAP="R",SDIR=1 S DONE=1 Q
140 ;Return up to NGET of the most recent/oldest entries.
141 S NFOUND=0,TDATE=""
142 F S TDATE=$O(TLIST(TDATE),SDIR) Q:(TDATE="")!(NFOUND=NGET) D
143 . S TIND=0
144 . F S TIND=$O(TLIST(TDATE,TIND)) Q:(TIND="")!(NFOUND=NGET) D
145 .. S NFOUND=NFOUND+1,FLIST(NFOUND)=TLIST(TDATE,TIND)
146 Q
147 ;
148 ;================================================================
149OVERLAP(START,STOP,BDT,EDT) ;Determine if the date range defined by START and
150 ;STOP overlaps with the date range defined by BDT and EDT. The return
151 ;value "O" means they overlap, "L" means START, STOP is to the
152 ;left of BDT, EDT and "R" means it is to the right.
153 I EDT<START Q "R"
154 I STOP<BDT Q "L"
155 Q "O"
156 ;
157 ;================================================================
158STATUSOK(STATUSA,FIEVD) ;Return true if the status in FIEVD matches one in
159 ;the list in STATUSA.
160 I '$D(FIEVD("STATUS")) Q 1
161 N JND,OK
162 S OK=0
163 F JND=1:1:STATUSA(0) Q:OK D
164 . I STATUSA(JND)="*" S OK=1 Q
165 . I STATUSA(JND)=FIEVD("STATUS") S OK=1 Q
166 Q OK
167 ;
Note: See TracBrowser for help on using the repository browser.