PXRMRUL1 ;SLC/AGP,PKR - Patient list routines. ;Dec 30, 2020@16:03
;;2.0;CLINICAL REMINDERS;**4,6,26,47,45,71**;Feb 04, 2005;Build 43
;
;
ASK(PLIEN,OPT) ;Verify patient list name
N X,Y,TEXT
K DIROUT,DIRUT,DTOUT,DUOUT
S DIR(0)="YA0"
S DIR("A")=OPT_" patient list "_$P($G(^PXRMXP(810.5,PLIEN,0)),U)_"?: "
S DIR("B")="N"
S DIR("?")="Enter Y or N. For detailed help type ??"
W !
D ^DIR K DIR
I $D(DIROUT) S DTOUT=1
I $D(DTOUT)!($D(DUOUT)) Q
I $E(Y(0))="N" S DUOUT=1 Q
Q
;
COPY(IENO) ;Copy patient list
;Check if OK to copy
D ASK(IENO,"Copy") Q:$D(DUOUT)!$D(DTOUT)
N FDA,IENN,IND,MSG,NNAME,ODATA,OEPIEN,ONAME,ORULE,PATCREAT,TEXT,X,Y,TYPE
;Select list to copy to
S TEXT="Select PATIENT LIST name to copy to: "
D PLIST^PXRMLCR(.IENN,TEXT,IENO) Q:$D(DUOUT)!$D(DTOUT) Q:'IENN
S NNAME=$P($G(^PXRMXP(810.5,IENN,0)),U)
;
;Get original Patient List record
S ODATA=$G(^PXRMXP(810.5,IENO,0))
S ONAME=$P(ODATA,U),OEPIEN=$P(ODATA,U,5),ORULE=$P(ODATA,U,6)
;
M ^PXRMXP(810.5,IENN)=^PXRMXP(810.5,IENO)
D ASK^PXRMXD(.PATCREAT,"Secure list?: ",2)
;Update header info
S TYPE=$S($G(PATCREAT)="Y":"PVT",1:"PUB")
S IND=IENN_","
S FDA(810.5,IND,.01)=NNAME
S FDA(810.5,IND,.04)=$$NOW^XLFDT
S FDA(810.5,IND,.05)=OEPIEN
S FDA(810.5,IND,.06)=ORULE
S FDA(810.5,IND,.07)=$G(DUZ)
S FDA(810.5,IND,.08)=TYPE
D UPDATE^DIE("","FDA","","MSG")
;Error
I $D(MSG) D ERR
;
W !!,"Completed copy of '"_ONAME_"'"
W !,"into '"_NNAME_"'",! H 2
K ^TMP($J,"PXRMRULE")
Q
;
CRLST(NAME,CLASS) ;Create new patient list
N IEN
;Check if name exists
S IEN=$O(^PXRMXP(810.5,"B",NAME,"")) I IEN Q IEN
;Otherwise create national entry
N FDA,FDAIEN,MSG
S FDA(810.5,"+1,",.01)=NAME
S FDA(810.5,"+1,",100)=CLASS
S FDA(810.5,"+1,",.07)=$G(DUZ)
;Make stub public
S FDA(810.5,"+1,",.08)="PUB"
D UPDATE^DIE("","FDA","FDAIEN","MSG")
;Error
I $D(MSG) Q 0
;Otherwise list ien
Q FDAIEN(1)
;
COUNT(NODE) ;Count the number of entries.
N DFN,NUM
S (DFN,NUM)=0
F S DFN=$O(^TMP($J,NODE,DFN)) Q:DFN="" S NUM=NUM+1
Q NUM
;
DELETE(LIST) ;Delete Patient list
I '$$VEDIT^PXRMUTIL("^PXRMXP(810.5,",LIST) D Q
.W !!,?5,"VA- and national class patient lists may not be deleted" H 2
.S DUOUT=1
;Check if this is the right list
D ASK(LIST,"Delete") Q:$D(DUOUT)!$D(DTOUT)
;
N DA,DIK,DUOUT
;Lock patient list
D LOCK Q:$D(DUOUT)
;Kill List
S DA=LIST,DIK="^PXRMXP(810.5,"
D ^DIK
;Unlock patient list
D UNLOCK
Q
;
DATECHK(DATE) ;
I DATE=0 Q 1
S DATE=$$STRREP^PXRMUTIL(DATE,"BDT","T")
Q $$VDT^PXRMINTR(DATE)
;
DATES(LBBDT,LBEDT,RBDT,REDT,FARR) ;Set the dates in the finding array to
;FileMan dates.
N FI,PXRMDATE,TBDT,TEDT
S FI=0
F S FI=+$O(FARR(20,FI)) Q:FI=0 D
. S TBDT=$P(FARR(20,FI,0),U,8),TEDT=$P(FARR(20,FI,0),U,11)
. I TBDT="",TEDT="" D
.. S $P(FARR(20,FI,0),U,8)=RBDT,$P(FARR(20,FI,0),U,11)=REDT
. E D
.. S PXRMDATE=$S(TBDT["BDT":LBBDT,1:LBEDT)
.. S TBDT=$S(TBDT="":0,TBDT=0:0,TBDT="BDT":LBBDT,1:$$CTFMD^PXRMDATE(TBDT))
.. S PXRMDATE=$S(TEDT["BDT":LBBDT,1:LBEDT)
.. S TEDT=$S(TEDT="":"T",TEDT=0:"T",TEDT="BDT":LBBDT,1:TEDT)
.. S TEDT=$$CTFMD^PXRMDATE(TEDT)
.. S $P(FARR(20,FI,0),U,8)=TBDT,$P(FARR(20,FI,0),U,11)=TEDT
Q
;
ERR ;Error Handler
N ERROR,IC,REF
S ERROR(1)="Unable to build patient list : "
S ERROR(2)=NAME
S ERROR(3)="Error in UPDATE^DIE, needs further investigation"
; Move MSG into Error
S REF="MSG"
F IC=4:1 S REF=$Q(@REF) Q:REF="" S ERROR(IC)=REF_"="_@REF
;Screen message
D EN^DDIOL(.ERROR)
Q
;
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"")"
;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) D
.M ^TMP($J,FROUT,DFN,"DATA")=DATA
.I $G(TFIEV(1,"DAS"))'="" S ^TMP($J,FROUT,DFN,"DATA",""_TNAME_",""DAS""")=TFIEV(1,"DAS")
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
;
LOCK L +^PXRMXP(810.5,LIST):DILOCKTM
E W !!?5,"Another user is using this patient list" S DUOUT=1
Q
;
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,LBBDT,LBEDT,RSTART,RSTOP,PNODE) ;Process reminder finding rule
N DEFARR,PXRMDATE
D DEF^PXRMLDR(RIEN,.DEFARR)
D DATES(LBBDT,LBEDT,RSTART,RSTOP,.DEFARR)
S PXRMDATE=RSTOP
D BLDPLST^PXRMPLST(.DEFARR,PNODE,1)
;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,LBBDT,LBEDT,RSTART,RSTOP,PNODE,INST) ;Process TERM finding
;rules
N FINDPA,FINDING,FNAME,PLIST,PXRMDATE,PXRMDEBG
N TERMARR,TFIEV,TNAME,OLDINST
;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)
S OLDINST=INST
;Set begin and end dates in the term.
D DATES(LBBDT,LBEDT,RSTART,RSTOP,.TERMARR)
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^PXRMTERL(.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 '$D(INST) S INST=OLDINST
.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
;
UNLOCK L -^PXRMXP(810.5,LIST) Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMRUL1 7012 printed Apr 09, 2024@20:51:23 Page 2
PXRMRUL1 ;SLC/AGP,PKR - Patient list routines. ;Dec 30, 2020@16:03
+1 ;;2.0;CLINICAL REMINDERS;**4,6,26,47,45,71**;Feb 04, 2005;Build 43
+2 ;
+3 ;
ASK(PLIEN,OPT) ;Verify patient list name
+1 NEW X,Y,TEXT
+2 KILL DIROUT,DIRUT,DTOUT,DUOUT
+3 SET DIR(0)="YA0"
+4 SET DIR("A")=OPT_" patient list "_$PIECE($GET(^PXRMXP(810.5,PLIEN,0)),U)_"?: "
+5 SET DIR("B")="N"
+6 SET DIR("?")="Enter Y or N. For detailed help type ??"
+7 WRITE !
+8 DO ^DIR
KILL DIR
+9 IF $DATA(DIROUT)
SET DTOUT=1
+10 IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+11 IF $EXTRACT(Y(0))="N"
SET DUOUT=1
QUIT
+12 QUIT
+13 ;
COPY(IENO) ;Copy patient list
+1 ;Check if OK to copy
+2 DO ASK(IENO,"Copy")
if $DATA(DUOUT)!$DATA(DTOUT)
QUIT
+3 NEW FDA,IENN,IND,MSG,NNAME,ODATA,OEPIEN,ONAME,ORULE,PATCREAT,TEXT,X,Y,TYPE
+4 ;Select list to copy to
+5 SET TEXT="Select PATIENT LIST name to copy to: "
+6 DO PLIST^PXRMLCR(.IENN,TEXT,IENO)
if $DATA(DUOUT)!$DATA(DTOUT)
QUIT
if 'IENN
QUIT
+7 SET NNAME=$PIECE($GET(^PXRMXP(810.5,IENN,0)),U)
+8 ;
+9 ;Get original Patient List record
+10 SET ODATA=$GET(^PXRMXP(810.5,IENO,0))
+11 SET ONAME=$PIECE(ODATA,U)
SET OEPIEN=$PIECE(ODATA,U,5)
SET ORULE=$PIECE(ODATA,U,6)
+12 ;
+13 MERGE ^PXRMXP(810.5,IENN)=^PXRMXP(810.5,IENO)
+14 DO ASK^PXRMXD(.PATCREAT,"Secure list?: ",2)
+15 ;Update header info
+16 SET TYPE=$SELECT($GET(PATCREAT)="Y":"PVT",1:"PUB")
+17 SET IND=IENN_","
+18 SET FDA(810.5,IND,.01)=NNAME
+19 SET FDA(810.5,IND,.04)=$$NOW^XLFDT
+20 SET FDA(810.5,IND,.05)=OEPIEN
+21 SET FDA(810.5,IND,.06)=ORULE
+22 SET FDA(810.5,IND,.07)=$GET(DUZ)
+23 SET FDA(810.5,IND,.08)=TYPE
+24 DO UPDATE^DIE("","FDA","","MSG")
+25 ;Error
+26 IF $DATA(MSG)
DO ERR
+27 ;
+28 WRITE !!,"Completed copy of '"_ONAME_"'"
+29 WRITE !,"into '"_NNAME_"'",!
HANG 2
+30 KILL ^TMP($JOB,"PXRMRULE")
+31 QUIT
+32 ;
CRLST(NAME,CLASS) ;Create new patient list
+1 NEW IEN
+2 ;Check if name exists
+3 SET IEN=$ORDER(^PXRMXP(810.5,"B",NAME,""))
IF IEN
QUIT IEN
+4 ;Otherwise create national entry
+5 NEW FDA,FDAIEN,MSG
+6 SET FDA(810.5,"+1,",.01)=NAME
+7 SET FDA(810.5,"+1,",100)=CLASS
+8 SET FDA(810.5,"+1,",.07)=$GET(DUZ)
+9 ;Make stub public
+10 SET FDA(810.5,"+1,",.08)="PUB"
+11 DO UPDATE^DIE("","FDA","FDAIEN","MSG")
+12 ;Error
+13 IF $DATA(MSG)
QUIT 0
+14 ;Otherwise list ien
+15 QUIT FDAIEN(1)
+16 ;
COUNT(NODE) ;Count the number of entries.
+1 NEW DFN,NUM
+2 SET (DFN,NUM)=0
+3 FOR
SET DFN=$ORDER(^TMP($JOB,NODE,DFN))
if DFN=""
QUIT
SET NUM=NUM+1
+4 QUIT NUM
+5 ;
DELETE(LIST) ;Delete Patient list
+1 IF '$$VEDIT^PXRMUTIL("^PXRMXP(810.5,",LIST)
Begin DoDot:1
+2 WRITE !!,?5,"VA- and national class patient lists may not be deleted"
HANG 2
+3 SET DUOUT=1
End DoDot:1
QUIT
+4 ;Check if this is the right list
+5 DO ASK(LIST,"Delete")
if $DATA(DUOUT)!$DATA(DTOUT)
QUIT
+6 ;
+7 NEW DA,DIK,DUOUT
+8 ;Lock patient list
+9 DO LOCK
if $DATA(DUOUT)
QUIT
+10 ;Kill List
+11 SET DA=LIST
SET DIK="^PXRMXP(810.5,"
+12 DO ^DIK
+13 ;Unlock patient list
+14 DO UNLOCK
+15 QUIT
+16 ;
DATECHK(DATE) ;
+1 IF DATE=0
QUIT 1
+2 SET DATE=$$STRREP^PXRMUTIL(DATE,"BDT","T")
+3 QUIT $$VDT^PXRMINTR(DATE)
+4 ;
DATES(LBBDT,LBEDT,RBDT,REDT,FARR) ;Set the dates in the finding array to
+1 ;FileMan dates.
+2 NEW FI,PXRMDATE,TBDT,TEDT
+3 SET FI=0
+4 FOR
SET FI=+$ORDER(FARR(20,FI))
if FI=0
QUIT
Begin DoDot:1
+5 SET TBDT=$PIECE(FARR(20,FI,0),U,8)
SET TEDT=$PIECE(FARR(20,FI,0),U,11)
+6 IF TBDT=""
IF TEDT=""
Begin DoDot:2
+7 SET $PIECE(FARR(20,FI,0),U,8)=RBDT
SET $PIECE(FARR(20,FI,0),U,11)=REDT
End DoDot:2
+8 IF '$TEST
Begin DoDot:2
+9 SET PXRMDATE=$SELECT(TBDT["BDT":LBBDT,1:LBEDT)
+10 SET TBDT=$SELECT(TBDT="":0,TBDT=0:0,TBDT="BDT":LBBDT,1:$$CTFMD^PXRMDATE(TBDT))
+11 SET PXRMDATE=$SELECT(TEDT["BDT":LBBDT,1:LBEDT)
+12 SET TEDT=$SELECT(TEDT="":"T",TEDT=0:"T",TEDT="BDT":LBBDT,1:TEDT)
+13 SET TEDT=$$CTFMD^PXRMDATE(TEDT)
+14 SET $PIECE(FARR(20,FI,0),U,8)=TBDT
SET $PIECE(FARR(20,FI,0),U,11)=TEDT
End DoDot:2
End DoDot:1
+15 QUIT
+16 ;
ERR ;Error Handler
+1 NEW ERROR,IC,REF
+2 SET ERROR(1)="Unable to build patient list : "
+3 SET ERROR(2)=NAME
+4 SET ERROR(3)="Error in UPDATE^DIE, needs further investigation"
+5 ; Move MSG into Error
+6 SET REF="MSG"
+7 FOR IC=4:1
SET REF=$QUERY(@REF)
if REF=""
QUIT
SET ERROR(IC)=REF_"="_@REF
+8 ;Screen message
+9 DO EN^DDIOL(.ERROR)
+10 QUIT
+11 ;
INSERT(FROUT,DFN,TNAME,TFIEV,RSTOP) ;Save patient data.
+1 IF TFIEV(1)=0
QUIT
+2 NEW DATA,DONE,IND,LEN,REF,ROOT,START,SUB,TEMP
+3 SET REF="TFIEV(1,""CSUB"")"
+4 ;Build the root so we can tell when we are done.
+5 SET TEMP=$NAME(@REF)
+6 SET ROOT=$PIECE(TEMP,")",1)
+7 SET REF=$QUERY(@REF)
+8 IF REF'[ROOT
QUIT
+9 SET DONE=0
+10 FOR
if (REF="")!(DONE)
QUIT
Begin DoDot:1
+11 SET START=$FIND(REF,ROOT)
+12 SET LEN=$LENGTH(REF)-1
+13 SET IND=$EXTRACT(REF,START,LEN)
+14 SET DATA(TNAME_IND)=@REF
+15 SET REF=$QUERY(@REF)
+16 IF REF'[ROOT
SET DONE=1
End DoDot:1
+17 IF $DATA(DATA)
Begin DoDot:1
+18 MERGE ^TMP($JOB,FROUT,DFN,"DATA")=DATA
+19 IF $GET(TFIEV(1,"DAS"))'=""
SET ^TMP($JOB,FROUT,DFN,"DATA",""_TNAME_",""DAS""")=TFIEV(1,"DAS")
End DoDot:1
+20 QUIT
+21 ;
INST(DFN) ;Get the PCMM Institution.
+1 NEW DATE,INST
+2 ;Check PCMM
+3 SET DATE=$SELECT($GET(PXRMDATE)'="":$PIECE(PXRMDATE,"."),1:DT)
+4 ;DBIA #1916
+5 SET INST=$PIECE($$INSTPCTM^SCAPMC(DFN,DATE),U,3,4)
+6 QUIT INST
+7 ;
LOCK LOCK +^PXRMXP(810.5,LIST):DILOCKTM
+1 IF '$TEST
WRITE !!?5,"Another user is using this patient list"
SET DUOUT=1
+2 QUIT
+3 ;
LOGOP(LIST1,LIST2,LOGOP) ;Given LIST1 and LIST2 apply the logical
+1 ;operator LOGOP to generate a new list and return it in LIST1
+2 NEW DFN1,DFN2
+3 IF LOGOP="&"
Begin DoDot:1
+4 SET DFN1=""
+5 FOR
SET DFN1=$ORDER(^TMP($JOB,LIST1,DFN1))
if DFN1=""
QUIT
Begin DoDot:2
+6 IF $DATA(^TMP($JOB,LIST2,DFN1))
MERGE ^TMP($JOB,LIST1,DFN1)=^TMP($JOB,LIST2,DFN1)
QUIT
+7 KILL ^TMP($JOB,LIST1,DFN1)
End DoDot:2
End DoDot:1
QUIT
+8 ;
+9 ;"~" represents "&'".
+10 IF LOGOP="~"
Begin DoDot:1
+11 SET DFN1=""
+12 FOR
SET DFN1=$ORDER(^TMP($JOB,LIST1,DFN1))
if DFN1=""
QUIT
Begin DoDot:2
+13 IF $DATA(^TMP($JOB,LIST2,DFN1))
KILL ^TMP($JOB,LIST1,DFN1)
End DoDot:2
End DoDot:1
QUIT
+14 ;
+15 IF LOGOP="!"
Begin DoDot:1
+16 SET DFN2=""
+17 FOR
SET DFN2=$ORDER(^TMP($JOB,LIST2,DFN2))
if DFN2=""
QUIT
Begin DoDot:2
+18 MERGE ^TMP($JOB,LIST1,DFN2)=^TMP($JOB,LIST2,DFN2)
End DoDot:2
End DoDot:1
+19 QUIT
+20 ;
REM(FRACT,RIEN,LBBDT,LBEDT,RSTART,RSTOP,PNODE) ;Process reminder finding rule
+1 NEW DEFARR,PXRMDATE
+2 DO DEF^PXRMLDR(RIEN,.DEFARR)
+3 DO DATES(LBBDT,LBEDT,RSTART,RSTOP,.DEFARR)
+4 SET PXRMDATE=RSTOP
+5 DO BLDPLST^PXRMPLST(.DEFARR,PNODE,1)
+6 ;Remove, Select or Add Findings operations
+7 IF FRACT="A"
DO LOGOP(FROUT,PNODE,"!")
QUIT
+8 IF FRACT="D"
DO LOGOP(FROUT,PNODE,"~")
QUIT
+9 IF FRACT="S"
DO LOGOP(FROUT,PNODE,"&")
QUIT
+10 QUIT
+11 ;
TERM(FRACT,FRTIEN,LBBDT,LBEDT,RSTART,RSTOP,PNODE,INST) ;Process TERM finding
+1 ;rules
+2 NEW FINDPA,FINDING,FNAME,PLIST,PXRMDATE,PXRMDEBG
+3 NEW TERMARR,TFIEV,TNAME,OLDINST
+4 ;Get term definition array
+5 DO TERM^PXRMLDR(FRTIEN,.TERMARR)
+6 SET TNAME=$PIECE(TERMARR(0),U,1)
+7 SET INST=$SELECT(FRACT'="F":0,TNAME="VA-PCMM INSTITUTION":1,TNAME="VA-IHD STATION CODE":1,1:0)
+8 SET OLDINST=INST
+9 ;Set begin and end dates in the term.
+10 DO DATES(LBBDT,LBEDT,RSTART,RSTOP,.TERMARR)
+11 SET $PIECE(FINDPA(0),U,8)=RSTART
SET $PIECE(FINDPA(0),U,11)=RSTOP
SET PXRMDATE=RSTOP
+12 ;
+13 ;Add operation
+14 IF FRACT="A"
Begin DoDot:1
+15 ;Process term for date range
+16 DO EVALPL^PXRMTERL(.FINDPA,.TERMARR,PNODE)
+17 ;Merge lists if operation is add
+18 MERGE ^TMP($JOB,FROUT)=^TMP($JOB,PNODE,1)
End DoDot:1
QUIT
+19 ;Remove, Select or Insert Findings operations
+20 IF FRACT="F"
SET PXRMDEBG=1
+21 SET DFN=0
+22 FOR
SET DFN=$ORDER(^TMP($JOB,FROUT,DFN))
if 'DFN
QUIT
Begin DoDot:1
+23 IF '$DATA(INST)
SET INST=OLDINST
+24 IF INST
SET ^TMP($JOB,FROUT,DFN,"INST")=$$INST(DFN)
QUIT
+25 ;Evaluate term
+26 KILL TFIEV
DO IEVALTER^PXRMTERM(DFN,.FINDPA,.TERMARR,1,.TFIEV)
+27 ;Delete any ^TMP patient in PLIST if action is remove
+28 IF FRACT="R"
IF TFIEV(1)
KILL ^TMP($JOB,FROUT,DFN)
QUIT
+29 ;Delete any ^TMP patient not in PLIST if action is select
+30 IF FRACT="S"
IF 'TFIEV(1)
KILL ^TMP($JOB,FROUT,DFN)
QUIT
+31 IF FRACT="F"
IF TFIEV(1)
Begin DoDot:2
+32 SET FINDING=TFIEV(1,"FINDING")
+33 IF '$DATA(FNAME(FINDING))
SET FNAME(FINDING)=$$GETFNAME^PXRMDATA(FINDING)
+34 SET TFIEV(1,"CSUB","FINDING NAME")=FNAME(FINDING)
+35 DO INSERT(FROUT,DFN,TNAME,.TFIEV,RSTOP)
End DoDot:2
End DoDot:1
+36 QUIT
+37 ;
UNLOCK LOCK -^PXRMXP(810.5,LIST)
QUIT
+1 ;
