source: WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMRUL1.m@ 724

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

revised back to 6/30/08 version

File size: 3.0 KB
Line 
1PXRMRUL1 ; SLC/AGP,PKR - Patient list routines. ; 08/11/2006
2 ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
3 ;
4DATECHK(DATE) ;
5 I DATE=0 Q 1
6 S DATE=$$STRREP^PXRMUTIL(DATE,"BDT","T")
7 Q $$VDT^PXRMINTR(DATE)
8 ;
9INSERT(FROUT,DFN,TNAME,TFIEV,RSTOP) ;Save patient data.
10 I TFIEV(1)=0 Q
11 N DATA,DONE,IND,LEN,REF,ROOT,START,SUB,TEMP
12 S REF="TFIEV(1,""CSUB"")"
13 S PROOT=$P(REF,")",1)
14 ;Build the root so we can tell when we are done.
15 S TEMP=$NA(@REF)
16 S ROOT=$P(TEMP,")",1)
17 S REF=$Q(@REF)
18 I REF'[ROOT Q
19 S DONE=0
20 F Q:(REF="")!(DONE) D
21 . S START=$F(REF,ROOT)
22 . S LEN=$L(REF)-1
23 . S IND=$E(REF,START,LEN)
24 . S DATA(TNAME_IND)=@REF
25 . S REF=$Q(@REF)
26 . I REF'[ROOT S DONE=1
27 I $D(DATA) M ^TMP($J,FROUT,DFN,"DATA")=DATA
28 Q
29 ;
30INST(DFN) ;Get the PCMM Institution.
31 N DATE,INST
32 ;Check PCMM
33 S DATE=$S($G(PXRMDATE)'="":$P(PXRMDATE,"."),1:DT)
34 ;DBIA #1916
35 S INST=$P($$INSTPCTM^SCAPMC(DFN,DATE),U,3,4)
36 Q INST
37 ;
38LOGOP(LIST1,LIST2,LOGOP) ;Given LIST1 and LIST2 apply the logical
39 ;operator LOGOP to generate a new list and return it in LIST1
40 N DFN1,DFN2
41 I LOGOP="&" D Q
42 . S DFN1=""
43 . F S DFN1=$O(^TMP($J,LIST1,DFN1)) Q:DFN1="" D
44 .. I $D(^TMP($J,LIST2,DFN1)) M ^TMP($J,LIST1,DFN1)=^TMP($J,LIST2,DFN1) Q
45 .. K ^TMP($J,LIST1,DFN1)
46 ;
47 ;"~" represents "&'".
48 I LOGOP="~" D Q
49 . S DFN1=""
50 . F S DFN1=$O(^TMP($J,LIST1,DFN1)) Q:DFN1="" D
51 .. I $D(^TMP($J,LIST2,DFN1)) K ^TMP($J,LIST1,DFN1)
52 ;
53 I LOGOP="!" D
54 . S DFN2=""
55 . F S DFN2=$O(^TMP($J,LIST2,DFN2)) Q:DFN2="" D
56 .. M ^TMP($J,LIST1,DFN2)=^TMP($J,LIST2,DFN2)
57 Q
58 ;
59REM(FRACT,RIEN,RSTART,RSTOP,PNODE) ;Process reminder finding rule
60 D BLDPLST^PXRMPLST(RIEN,PNODE,1,RSTOP)
61 ;Remove, Select or Add Findings operations
62 I FRACT="A" D LOGOP(FROUT,PNODE,"!") Q
63 I FRACT="D" D LOGOP(FROUT,PNODE,"~") Q
64 I FRACT="S" D LOGOP(FROUT,PNODE,"&") Q
65 Q
66 ;
67TERM(FRACT,FRTIEN,RSTART,RSTOP,PNODE,INST) ;Process TERM finding rule
68 N FINDPA,FINDING,FNAME,PLIST,PXRMDATE,PXRMDEBG,TERMARR,TFIEV,TNAME
69 ;Get term definition array
70 D TERM^PXRMLDR(FRTIEN,.TERMARR)
71 S TNAME=$P(TERMARR(0),U,1)
72 S INST=$S(FRACT'="F":0,TNAME="VA-PCMM INSTITUTION":1,TNAME="VA-IHD STATION CODE":1,1:0)
73 ;Set start and end dates
74 S $P(FINDPA(0),U,8)=RSTART,$P(FINDPA(0),U,11)=RSTOP,PXRMDATE=RSTOP
75 ;
76 ;Add operation
77 I FRACT="A" D Q
78 .;Process term for date range
79 .D EVALPL^PXRMTERM(.FINDPA,.TERMARR,PNODE)
80 .;Merge lists if operation is add
81 .M ^TMP($J,FROUT)=^TMP($J,PNODE,1)
82 ;Remove, Select or Insert Findings operations
83 I FRACT="F" S PXRMDEBG=1
84 S DFN=0
85 F S DFN=$O(^TMP($J,FROUT,DFN)) Q:'DFN D
86 .I INST S ^TMP($J,FROUT,DFN,"INST")=$$INST(DFN) Q
87 .;Evaluate term
88 .K TFIEV D IEVALTER^PXRMTERM(DFN,.FINDPA,.TERMARR,1,.TFIEV)
89 .;Delete any ^TMP patient in PLIST if action is remove
90 .I FRACT="R",TFIEV(1) K ^TMP($J,FROUT,DFN) Q
91 .;Delete any ^TMP patient not in PLIST if action is select
92 .I FRACT="S",'TFIEV(1) K ^TMP($J,FROUT,DFN) Q
93 .I FRACT="F",TFIEV(1) D
94 .. S FINDING=TFIEV(1,"FINDING")
95 .. I '$D(FNAME(FINDING)) S FNAME(FINDING)=$$GETFNAME^PXRMDATA(FINDING)
96 .. S TFIEV(1,"CSUB","FINDING NAME")=FNAME(FINDING)
97 .. D INSERT(FROUT,DFN,TNAME,.TFIEV,RSTOP)
98 Q
99 ;
Note: See TracBrowser for help on using the repository browser.