source: FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMRUL1.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.5 KB
Line 
1PXRMRUL1 ; SLC/AGP,PKR - Patient list routines. ; 03/29/2007
2 ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
3 ;
4 ;
5ASK(PLIEN,OPT) ;Verify patient list name
6 N X,Y,TEXT
7 K DIROUT,DIRUT,DTOUT,DUOUT
8 S DIR(0)="YA0"
9 S DIR("A")=OPT_" patient list "_$P($G(^PXRMXP(810.5,PLIEN,0)),U)_"?: "
10 S DIR("B")="N"
11 S DIR("?")="Enter Y or N. For detailed help type ??"
12 W !
13 D ^DIR K DIR
14 I $D(DIROUT) S DTOUT=1
15 I $D(DTOUT)!($D(DUOUT)) Q
16 I $E(Y(0))="N" S DUOUT=1 Q
17 Q
18 ;
19COPY(IENO) ;Copy patient list
20 ;Check if OK to copy
21 D ASK(IENO,"Copy") Q:$D(DUOUT)!$D(DTOUT)
22 N FDA,IENN,IND,MSG,NNAME,ODATA,OEPIEN,ONAME,ORULE,PATCREAT,TEXT,X,Y
23 ;Select list to copy to
24 S TEXT="Select PATIENT LIST name to copy to: "
25 D PLIST^PXRMLCR(.IENN,TEXT,IENO) Q:$D(DUOUT)!$D(DTOUT) Q:'IENN
26 S NNAME=$P($G(^PXRMXP(810.5,IENN,0)),U)
27 ;
28 ;Get original Patient List record
29 S ODATA=$G(^PXRMXP(810.5,IENO,0))
30 S ONAME=$P(ODATA,U),OEPIEN=$P(ODATA,U,5),ORULE=$P(ODATA,U,6)
31 ;
32 M ^PXRMXP(810.5,IENN)=^PXRMXP(810.5,IENO)
33 D ASK^PXRMXD(.PATCREAT,"Secure list?: ",2)
34 ;Update header info
35 S TYPE=$S($G(PATCREAT)="Y":"PVT",1:"PUB")
36 S IND=IENN_","
37 S FDA(810.5,IND,.01)=NNAME
38 S FDA(810.5,IND,.04)=$$NOW^XLFDT
39 S FDA(810.5,IND,.05)=OEPIEN
40 S FDA(810.5,IND,.06)=ORULE
41 S FDA(810.5,IND,.07)=$G(DUZ)
42 S FDA(810.5,IND,.08)=TYPE
43 D UPDATE^DIE("","FDA","","MSG")
44 ;Error
45 I $D(MSG) D ERR
46 ;
47 W !!,"Completed copy of '"_ONAME_"'"
48 W !,"into '"_NNAME_"'",! H 2
49 K ^TMP($J,"PXRMRULE")
50 Q
51 ;
52CRLST(NAME,CLASS) ;Create new patient list
53 N IEN
54 ;Check if name exists
55 S IEN=$O(^PXRMXP(810.5,"B",NAME,"")) I IEN Q IEN
56 ;Otherwise create national entry
57 N FDA,FDAIEN,MSG
58 S FDA(810.5,"+1,",.01)=NAME
59 S FDA(810.5,"+1,",100)=CLASS
60 S FDA(810.5,"+1,",.07)=$G(DUZ)
61 ;Make stub public
62 S FDA(810.5,"+1,",.08)="PUB"
63 D UPDATE^DIE("","FDA","FDAIEN","MSG")
64 ;Error
65 I $D(MSG) Q 0
66 ;Otherwise list ien
67 Q FDAIEN(1)
68 ;
69COUNT(NODE) ;Count the number of entries.
70 N DFN,NUM
71 S (DFN,NUM)=0
72 F S DFN=$O(^TMP($J,NODE,DFN)) Q:DFN="" S NUM=NUM+1
73 Q NUM
74 ;
75DELETE(LIST) ;Delete Patient list
76 I '$$VEDIT^PXRMUTIL("^PXRMXP(810.5,",LIST) D Q
77 .W !!,?5,"VA- and national class patient lists may not be deleted" H 2
78 .S DUOUT=1
79 ;Check if this is the right list
80 D ASK(LIST,"Delete") Q:$D(DUOUT)!$D(DTOUT)
81 ;
82 N DA,DIK,DUOUT
83 ;Lock patient list
84 D LOCK Q:$D(DUOUT)
85 ;Kill List
86 S DA=LIST,DIK="^PXRMXP(810.5,"
87 D ^DIK
88 ;Unlock patient list
89 D UNLOCK
90 Q
91 ;
92DATECHK(DATE) ;
93 I DATE=0 Q 1
94 S DATE=$$STRREP^PXRMUTIL(DATE,"BDT","T")
95 Q $$VDT^PXRMINTR(DATE)
96 ;
97DATES(LBBDT,LBEDT,RBDT,REDT,FARR) ;Set the dates in the finding array to
98 ;FileMan dates.
99 N FI,PXRMDATE,TBDT,TEDT
100 S FI=0
101 F S FI=+$O(FARR(20,FI)) Q:FI=0 D
102 . S TBDT=$P(FARR(20,FI,0),U,8),TEDT=$P(FARR(20,FI,0),U,11)
103 . I TBDT="",TEDT="" D
104 .. S $P(FARR(20,FI,0),U,8)=RBDT,$P(FARR(20,FI,0),U,11)=REDT
105 . E D
106 .. S PXRMDATE=$S(TBDT["BDT":LBBDT,1:LBEDT)
107 .. S TBDT=$S(TBDT="":0,TBDT=0:0,TBDT="BDT":LBBDT,1:$$CTFMD^PXRMDATE(TBDT))
108 .. S PXRMDATE=$S(TEDT["BDT":LBBDT,1:LBEDT)
109 .. S TEDT=$S(TEDT="":"T",TEDT=0:"T",TEDT="BDT":LBBDT,1:TEDT)
110 .. S TEDT=$$CTFMD^PXRMDATE(TEDT)
111 .. S $P(FARR(20,FI,0),U,8)=TBDT,$P(FARR(20,FI,0),U,11)=TEDT
112 Q
113 ;
114ERR ;Error Handler
115 N ERROR,IC,REF
116 S ERROR(1)="Unable to build patient list : "
117 S ERROR(2)=NAME
118 S ERROR(3)="Error in UPDATE^DIE, needs further investigation"
119 ; Move MSG into Error
120 S REF="MSG"
121 F IC=4:1 S REF=$Q(@REF) Q:REF="" S ERROR(IC)=REF_"="_@REF
122 ;Screen message
123 D EN^DDIOL(.ERROR)
124 Q
125 ;
126INSERT(FROUT,DFN,TNAME,TFIEV,RSTOP) ;Save patient data.
127 I TFIEV(1)=0 Q
128 N DATA,DONE,IND,LEN,REF,ROOT,START,SUB,TEMP
129 S REF="TFIEV(1,""CSUB"")"
130 S PROOT=$P(REF,")",1)
131 ;Build the root so we can tell when we are done.
132 S TEMP=$NA(@REF)
133 S ROOT=$P(TEMP,")",1)
134 S REF=$Q(@REF)
135 I REF'[ROOT Q
136 S DONE=0
137 F Q:(REF="")!(DONE) D
138 . S START=$F(REF,ROOT)
139 . S LEN=$L(REF)-1
140 . S IND=$E(REF,START,LEN)
141 . S DATA(TNAME_IND)=@REF
142 . S REF=$Q(@REF)
143 . I REF'[ROOT S DONE=1
144 I $D(DATA) M ^TMP($J,FROUT,DFN,"DATA")=DATA
145 Q
146 ;
147INST(DFN) ;Get the PCMM Institution.
148 N DATE,INST
149 ;Check PCMM
150 S DATE=$S($G(PXRMDATE)'="":$P(PXRMDATE,"."),1:DT)
151 ;DBIA #1916
152 S INST=$P($$INSTPCTM^SCAPMC(DFN,DATE),U,3,4)
153 Q INST
154 ;
155LOCK L +^PXRMXP(810.5,LIST):0
156 E W !!?5,"Another user is using this patient list" S DUOUT=1
157 Q
158 ;
159LOGOP(LIST1,LIST2,LOGOP) ;Given LIST1 and LIST2 apply the logical
160 ;operator LOGOP to generate a new list and return it in LIST1
161 N DFN1,DFN2
162 I LOGOP="&" D Q
163 . S DFN1=""
164 . F S DFN1=$O(^TMP($J,LIST1,DFN1)) Q:DFN1="" D
165 .. I $D(^TMP($J,LIST2,DFN1)) M ^TMP($J,LIST1,DFN1)=^TMP($J,LIST2,DFN1) Q
166 .. K ^TMP($J,LIST1,DFN1)
167 ;
168 ;"~" represents "&'".
169 I LOGOP="~" D Q
170 . S DFN1=""
171 . F S DFN1=$O(^TMP($J,LIST1,DFN1)) Q:DFN1="" D
172 .. I $D(^TMP($J,LIST2,DFN1)) K ^TMP($J,LIST1,DFN1)
173 ;
174 I LOGOP="!" D
175 . S DFN2=""
176 . F S DFN2=$O(^TMP($J,LIST2,DFN2)) Q:DFN2="" D
177 .. M ^TMP($J,LIST1,DFN2)=^TMP($J,LIST2,DFN2)
178 Q
179 ;
180REM(FRACT,RIEN,LBBDT,LBEDT,RSTART,RSTOP,PNODE) ;Process reminder finding rule
181 N DEFFARR,PXRMDATE
182 D DEF^PXRMLDR(RIEN,.DEFARR)
183 D DATES(LBBDT,LBEDT,RSTART,RSTOP,.DEFARR)
184 S PXRMDATE=RSTOP
185 D BLDPLST^PXRMPLST(.DEFARR,PNODE,1)
186 ;Remove, Select or Add Findings operations
187 I FRACT="A" D LOGOP(FROUT,PNODE,"!") Q
188 I FRACT="D" D LOGOP(FROUT,PNODE,"~") Q
189 I FRACT="S" D LOGOP(FROUT,PNODE,"&") Q
190 Q
191 ;
192TERM(FRACT,FRTIEN,LBBDT,LBEDT,RSTART,RSTOP,PNODE,INST) ;Process TERM finding
193 ;rules
194 N FINDPA,FINDING,FNAME,PLIST,PXRMDATE,PXRMDEBG
195 N TERMARR,TFIEV,TNAME
196 ;Get term definition array
197 D TERM^PXRMLDR(FRTIEN,.TERMARR)
198 S TNAME=$P(TERMARR(0),U,1)
199 S INST=$S(FRACT'="F":0,TNAME="VA-PCMM INSTITUTION":1,TNAME="VA-IHD STATION CODE":1,1:0)
200 ;Set begin and end dates in the term.
201 D DATES(LBBDT,LBEDT,RSTART,RSTOP,.TERMARR)
202 S $P(FINDPA(0),U,8)=RSTART,$P(FINDPA(0),U,11)=RSTOP,PXRMDATE=RSTOP
203 ;
204 ;Add operation
205 I FRACT="A" D Q
206 .;Process term for date range
207 .D EVALPL^PXRMTERL(.FINDPA,.TERMARR,PNODE)
208 .;Merge lists if operation is add
209 .M ^TMP($J,FROUT)=^TMP($J,PNODE,1)
210 ;Remove, Select or Insert Findings operations
211 I FRACT="F" S PXRMDEBG=1
212 S DFN=0
213 F S DFN=$O(^TMP($J,FROUT,DFN)) Q:'DFN D
214 .I INST S ^TMP($J,FROUT,DFN,"INST")=$$INST(DFN) Q
215 .;Evaluate term
216 .K TFIEV D IEVALTER^PXRMTERM(DFN,.FINDPA,.TERMARR,1,.TFIEV)
217 .;Delete any ^TMP patient in PLIST if action is remove
218 .I FRACT="R",TFIEV(1) K ^TMP($J,FROUT,DFN) Q
219 .;Delete any ^TMP patient not in PLIST if action is select
220 .I FRACT="S",'TFIEV(1) K ^TMP($J,FROUT,DFN) Q
221 .I FRACT="F",TFIEV(1) D
222 .. S FINDING=TFIEV(1,"FINDING")
223 .. I '$D(FNAME(FINDING)) S FNAME(FINDING)=$$GETFNAME^PXRMDATA(FINDING)
224 .. S TFIEV(1,"CSUB","FINDING NAME")=FNAME(FINDING)
225 .. D INSERT(FROUT,DFN,TNAME,.TFIEV,RSTOP)
226 Q
227 ;
228UNLOCK L -^PXRMXP(810.5,LIST) Q
229 ;
Note: See TracBrowser for help on using the repository browser.