100 lines
3.0 KiB
Mathematica
100 lines
3.0 KiB
Mathematica
PXRMRUL1 ; SLC/AGP,PKR - Patient list routines. ; 08/11/2006
|
|
;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
|
|
;
|
|
DATECHK(DATE) ;
|
|
I DATE=0 Q 1
|
|
S DATE=$$STRREP^PXRMUTIL(DATE,"BDT","T")
|
|
Q $$VDT^PXRMINTR(DATE)
|
|
;
|
|
INSERT(FROUT,DFN,TNAME,TFIEV,RSTOP) ;Save patient data.
|
|
I TFIEV(1)=0 Q
|
|
N DATA,DONE,IND,LEN,REF,ROOT,START,SUB,TEMP
|
|
S REF="TFIEV(1,""CSUB"")"
|
|
S PROOT=$P(REF,")",1)
|
|
;Build the root so we can tell when we are done.
|
|
S TEMP=$NA(@REF)
|
|
S ROOT=$P(TEMP,")",1)
|
|
S REF=$Q(@REF)
|
|
I REF'[ROOT Q
|
|
S DONE=0
|
|
F Q:(REF="")!(DONE) D
|
|
. S START=$F(REF,ROOT)
|
|
. S LEN=$L(REF)-1
|
|
. S IND=$E(REF,START,LEN)
|
|
. S DATA(TNAME_IND)=@REF
|
|
. S REF=$Q(@REF)
|
|
. I REF'[ROOT S DONE=1
|
|
I $D(DATA) M ^TMP($J,FROUT,DFN,"DATA")=DATA
|
|
Q
|
|
;
|
|
INST(DFN) ;Get the PCMM Institution.
|
|
N DATE,INST
|
|
;Check PCMM
|
|
S DATE=$S($G(PXRMDATE)'="":$P(PXRMDATE,"."),1:DT)
|
|
;DBIA #1916
|
|
S INST=$P($$INSTPCTM^SCAPMC(DFN,DATE),U,3,4)
|
|
Q INST
|
|
;
|
|
LOGOP(LIST1,LIST2,LOGOP) ;Given LIST1 and LIST2 apply the logical
|
|
;operator LOGOP to generate a new list and return it in LIST1
|
|
N DFN1,DFN2
|
|
I LOGOP="&" D Q
|
|
. S DFN1=""
|
|
. F S DFN1=$O(^TMP($J,LIST1,DFN1)) Q:DFN1="" D
|
|
.. I $D(^TMP($J,LIST2,DFN1)) M ^TMP($J,LIST1,DFN1)=^TMP($J,LIST2,DFN1) Q
|
|
.. K ^TMP($J,LIST1,DFN1)
|
|
;
|
|
;"~" represents "&'".
|
|
I LOGOP="~" D Q
|
|
. S DFN1=""
|
|
. F S DFN1=$O(^TMP($J,LIST1,DFN1)) Q:DFN1="" D
|
|
.. I $D(^TMP($J,LIST2,DFN1)) K ^TMP($J,LIST1,DFN1)
|
|
;
|
|
I LOGOP="!" D
|
|
. S DFN2=""
|
|
. F S DFN2=$O(^TMP($J,LIST2,DFN2)) Q:DFN2="" D
|
|
.. M ^TMP($J,LIST1,DFN2)=^TMP($J,LIST2,DFN2)
|
|
Q
|
|
;
|
|
REM(FRACT,RIEN,RSTART,RSTOP,PNODE) ;Process reminder finding rule
|
|
D BLDPLST^PXRMPLST(RIEN,PNODE,1,RSTOP)
|
|
;Remove, Select or Add Findings operations
|
|
I FRACT="A" D LOGOP(FROUT,PNODE,"!") Q
|
|
I FRACT="D" D LOGOP(FROUT,PNODE,"~") Q
|
|
I FRACT="S" D LOGOP(FROUT,PNODE,"&") Q
|
|
Q
|
|
;
|
|
TERM(FRACT,FRTIEN,RSTART,RSTOP,PNODE,INST) ;Process TERM finding rule
|
|
N FINDPA,FINDING,FNAME,PLIST,PXRMDATE,PXRMDEBG,TERMARR,TFIEV,TNAME
|
|
;Get term definition array
|
|
D TERM^PXRMLDR(FRTIEN,.TERMARR)
|
|
S TNAME=$P(TERMARR(0),U,1)
|
|
S INST=$S(FRACT'="F":0,TNAME="VA-PCMM INSTITUTION":1,TNAME="VA-IHD STATION CODE":1,1:0)
|
|
;Set start and end dates
|
|
S $P(FINDPA(0),U,8)=RSTART,$P(FINDPA(0),U,11)=RSTOP,PXRMDATE=RSTOP
|
|
;
|
|
;Add operation
|
|
I FRACT="A" D Q
|
|
.;Process term for date range
|
|
.D EVALPL^PXRMTERM(.FINDPA,.TERMARR,PNODE)
|
|
.;Merge lists if operation is add
|
|
.M ^TMP($J,FROUT)=^TMP($J,PNODE,1)
|
|
;Remove, Select or Insert Findings operations
|
|
I FRACT="F" S PXRMDEBG=1
|
|
S DFN=0
|
|
F S DFN=$O(^TMP($J,FROUT,DFN)) Q:'DFN D
|
|
.I INST S ^TMP($J,FROUT,DFN,"INST")=$$INST(DFN) Q
|
|
.;Evaluate term
|
|
.K TFIEV D IEVALTER^PXRMTERM(DFN,.FINDPA,.TERMARR,1,.TFIEV)
|
|
.;Delete any ^TMP patient in PLIST if action is remove
|
|
.I FRACT="R",TFIEV(1) K ^TMP($J,FROUT,DFN) Q
|
|
.;Delete any ^TMP patient not in PLIST if action is select
|
|
.I FRACT="S",'TFIEV(1) K ^TMP($J,FROUT,DFN) Q
|
|
.I FRACT="F",TFIEV(1) D
|
|
.. S FINDING=TFIEV(1,"FINDING")
|
|
.. I '$D(FNAME(FINDING)) S FNAME(FINDING)=$$GETFNAME^PXRMDATA(FINDING)
|
|
.. S TFIEV(1,"CSUB","FINDING NAME")=FNAME(FINDING)
|
|
.. D INSERT(FROUT,DFN,TNAME,.TFIEV,RSTOP)
|
|
Q
|
|
;
|