Index: WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMRULE.m
===================================================================
--- WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMRULE.m	(revision 613)
+++ WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMRULE.m	(revision 623)
@@ -1,221 +1,298 @@
-PXRMRULE	; SLC/PJH - Build Patient list from Rule Set ;03/27/2007
-	;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-	; 
-	; Called from PXRM PATIENT LIST CREATE protocol
-	;
-CLEAR(RULE,NODE)	;Clear workfile entries
-	N SEQ
-	S SEQ=""
-	F  S SEQ=$O(^PXRM(810.4,RULE,30,"B",SEQ)) Q:'SEQ  D
-	.K ^TMP($J,NODE_SEQ)
-	;clear FDA array
-	K ^TMP($J,"PXRMFDA")
-	Q
-	;
-INTR	;Input transform for #810.4 fields
-	Q
-	;
-LOAD(NODE,LIEN)	;Load Patient List
-	N DATA,DFN,SUB
-	S SUB=0
-	F  S SUB=$O(^PXRMXP(810.5,LIEN,30,SUB)) Q:'SUB  D
-	.S DATA=$G(^PXRMXP(810.5,LIEN,30,SUB,0)),DFN=$P(DATA,U) Q:'DFN
-	.;Store the patient IEN and institution in ^TMP
-	.S ^TMP($J,NODE,DFN)=$P(DATA,U,2)_U_$P($G(DATA),U,3)_U_$P($G(DATA),U,4)
-	Q
-	;
-PATS(FRACT,FROUT,PNODE,LIST)	;Process Patient List finding rule
-	;
-	N LIEN,LUVALUE
-	;Insert year and period into extract list name
-	I YEAR]"",LIST["yyyy" S LIST=$P(LIST,"yyyy")_YEAR_$P(LIST,"yyyy",2)
-	I PERIOD]"",LIST["nn" S LIST=$P(LIST,"nn")_$E(PERIOD,2,10)_$P(LIST,"nn",2)
-	;
-	S LUVALUE(1)=LIST
-	S LIEN=+$$FIND1^DIC(810.5,"","KUX",.LUVALUE) Q:'LIEN
-	;
-	;Add operation Load list
-	I FRACT="A" D LOAD(FROUT,LIEN) Q
-	;
-	;Remove or Select operations
-	;Load List
-	D LOAD(PNODE,LIEN)
-	;Check each patient
-	S DFN=0
-	F  S DFN=$O(^TMP($J,FROUT,DFN)) Q:'DFN  D
-	.;Delete any ^TMP patient in PLIST if action is remove
-	.I FRACT="R",$D(^TMP($J,PNODE,DFN)) K ^TMP($J,FROUT,DFN) Q
-	.;Delete any ^TMP patient not in PLIST if action is select
-	.I FRACT="S",'$D(^TMP($J,PNODE,DFN)) K ^TMP($J,FROUT,DFN)
-	Q
-	;
-START(RULESET,LIST,NODE,LBBDT,LBEDT,PAR,YEAR,PERIOD,INDP,INTP,EXTITR)	;
-	;Process rule set
-	;Clear ^TMP
-	D CLEAR(RULESET,NODE)
-	;
-	N CLASS,FRACT,FRDATA,FRDATES,FRIEN,FRLST,FRLIEN,FROLST,FROUT,FRPAT
-	N FRPERM,FRSTRT,FRTIEN,FRTYP,FSEQ,INC,INST,PXRMDATE,PXRMDDOC
-	N RBDT,REDT,RRIEN,RSDATA,RSDATES,SEQ,SUB
-	;Get class from extract parameter
-	I PAR S CLASS=$P($G(^PXRM(810.2,PAR,100)),U)
-	;Otherwise default to local
-	I $G(CLASS)="" S CLASS="L"
-	;PXRMDDOC=1 save list rule evaluation dates in ^TMP("PXRMDDOC",$J)
-	S PXRMDDOC=1
-	K ^TMP("PXRMDDOC",$J)
-	;Get each finding rule in sequence
-	S SEQ="",INC=0,INST=0
-	F  S SEQ=$O(^PXRM(810.4,RULESET,30,"B",SEQ)) Q:'SEQ  D
-	.;Save first sequence as default
-	.I INC=0 S INC=1,FSEQ=SEQ
-	.S SUB=$O(^PXRM(810.4,RULESET,30,"B",SEQ,"")) Q:'SUB
-	.S RSDATA=$G(^PXRM(810.4,RULESET,30,SUB,0)) Q:RSDATA=""
-	.S RSDATES=$G(^PXRM(810.4,RULESET,30,SUB,1))
-	.;Finding rule ien and action
-	.S FRIEN=$P(RSDATA,U,2),FRACT=$P(RSDATA,U,3) Q:'FRIEN  Q:FRACT=""
-	.;Check if entry is a finding rule (not a set or reminder rule)
-	.S FRDATA=$G(^PXRM(810.4,FRIEN,0)),FRTYP=$P(FRDATA,U,3) Q:FRTYP=3
-	.S FRDATES=$P(FRDATA,U,4,5)
-	.;Get term IEN for finding rule
-	.I FRTYP=1 S FRTIEN=$P(FRDATA,U,7) Q:'FRTIEN
-	.;Get Reminder definition IEN for Reminder rule
-	.I FRTYP=2 S RRIEN=$P(FRDATA,U,10) Q:'RRIEN
-	.;Get Extract Patient List name for patient list rule
-	.I FRTYP=5 S FRLST=$P($G(^PXRM(810.4,FRIEN,1)),U) D  Q:FRLST=""
-	..I +EXTITR>0 S FRLST=FRLST_"/"_EXTITR
-	..S FROLST=$P(FRDATA,U,8)
-	..I +FROLST>0 S FRLST=$P($G(^PXRMXP(810.5,FROLST,0)),U)
-	.;Determine RBDT and REDT
-	.D RDATES^PXRMEUT1(RSDATES,FRDATES,LBBDT,LBEDT,.RBDT,.REDT)
-	.S PXRMDATE=LBEDT
-	.;Get start sequence or start patient list
-	.S FRSTRT=$P(RSDATA,U,4),FRPAT=$P(RSDATA,U,5)
-	.;If sequence is defined use it
-	.I FRSTRT S FROUT=NODE_FRSTRT
-	.;If neither exist use first as default
-	.I FRSTRT="",FRPAT="" S FROUT=NODE_FSEQ
-	.;If start is patient list load patient list into workfile
-	.I FRSTRT="",FRPAT]"" S FROUT=NODE_SEQ D LOAD(FROUT,FRPAT)
-	.;Name of permanent list
-	.S FRPERM=$P(RSDATA,U,6)
-	.;
-	.;Build patient list in TMP
-	.N DFN,PNODE,TLIST
-	.S PNODE="PXRMEVAL"
-	.K ^TMP($J,PNODE)
-	.;Term finding rules
-	.I FRTYP=1 D TERM^PXRMRUL1(FRACT,FRTIEN,LBBDT,LBEDT,RBDT,REDT,PNODE,.INST)
-	.;Reminder Definition List Rule
-	.I FRTYP=2 D REM^PXRMRUL1(FRACT,RRIEN,LBBDT,LBEDT,RBDT,REDT,PNODE)
-	.;Patient list finding rules
-	.I FRTYP=5 D PATS(FRACT,FROUT,PNODE,FRLST)
-	.;Clear results file
-	.K ^TMP($J,PNODE)
-	.;
-	.;Build permanent list if required
-	.I FRPERM]"" D
-	..N FRPIEN
-	..;Get patient list IEN or create new patient list
-	..S FRPIEN=$$CRLST^PXRMRUL1(FRPERM,CLASS) Q:'FRPIEN
-	..;Update patient list
-	..D UPDLST(FROUT,FRPIEN,PAR,RULESET,INST,INDP,INTP)
-	;
-	;Save final results to patient list
-	I LIST'="",FROUT'="" D
-	. D RMPAT^PXRMEUT(FROUT,INDP,INTP)
-	. D UPDLST(FROUT,LIST,PAR,RULESET,INST,INDP,INTP)
-	.;PXRMDDOC=2 compare saved dates with those generated in
-	.;DOCUMENT^PXRMEUT.
-	. S PXRMDDOC=2
-	. D DOCUMENT^PXRMEUT(LIST,RULESET,INDP,INTP,LBBDT,LBEDT)
-	K ^TMP("PXRMDDOC",$J)
-	Q
-	;
-UPDLST(NODE,LIST,EPIEN,RULE,INST,INDP,INTP)	;Update patient list
-	N CNT,DA,DATA,DCNT,DECEASED,DFN,DNAME,DNAMEL,DOD,DUE,DUOUT,FDA
-	N INSTNAM,INSTNUM,LAST,MSG,NAME,ONODE
-	N RCNT,RIEN,RNAMEL,RNCNT,SUB,TEMP,TEST,TYPE,VALUE
-	;Lock patient list
-	D LOCK^PXRMRUL1 Q:$D(DUOUT)
-	S TEMP=^PXRMXP(810.5,LIST,0)
-	S NAME=$P(TEMP,U,1)
-	S $P(^PXRMXP(810.5,LIST,0),U,11)=INDP
-	S $P(^PXRMXP(810.5,LIST,0),U,12)=INTP
-	;
-	;Clear existing list.
-	K ^PXRMXP(810.5,LIST,30),^PXRMXP(810.5,LIST,35),^PXRMXP(810.5,LIST,45),^PXRMXP(810.5,LIST,200)
-	;
-	;Merge ^TMP into Patient List
-	S (DECEASED,TESTP)=""
-	S (CNT,DFN)=0
-	F  S DFN=$O(^TMP($J,NODE,DFN)) Q:'DFN  D
-	.S ONODE=$G(^TMP($J,NODE,DFN,"INST"))
-	.S INSTNUM=$P(ONODE,U,1),INSTNAM=$P(ONODE,U,2)
-	.S TEMP=DFN_U_INSTNUM_U_INSTNAM
-	.I INDP D
-	..;DBIA #10035
-	..S DOD=+$P($G(^DPT(DFN,.35)),U,1)
-	..S DECEASED=$S(DOD=0:0,1:1)
-	.;DBIA #3744
-	.I INTP S TESTP=$$TESTPAT^VADPT(DFN)
-	.S CNT=CNT+1,^PXRMXP(810.5,LIST,30,CNT,0)=DFN_U_INSTNUM_U_INSTNAM_U_DECEASED_U_TESTP
-	.S ^PXRMXP(810.5,LIST,30,"B",DFN,CNT)=""
-	.;
-	.;Save the reminder evaluation information only from Reports
-	.I $D(^TMP($J,NODE,DFN,"REM"))>0 D
-	..S (RIEN,RCNT,RNCNT)=0
-	..F  S RIEN=$O(^TMP($J,NODE,DFN,"REM",RIEN)) Q:RIEN'>0  D
-	...S RNAMEL(RIEN)=""
-	...S VALUE=^TMP($J,NODE,DFN,"REM",RIEN)
-	...S RCNT=RCNT+1
-	...S ^PXRMXP(810.5,LIST,30,CNT,"REM",RCNT,0)=VALUE
-	...S ^PXRMXP(810.5,LIST,30,CNT,"REM","B",RIEN,RCNT)=""
-	..S ^PXRMXP(810.5,LIST,30,CNT,1,0)=U_"810.532A"_U_RCNT_U_RCNT
-	.;
-	.I '$D(^TMP($J,NODE,DFN,"DATA")) Q
-	.S DCNT=0,DNAME=""
-	.F  S DNAME=$O(^TMP($J,NODE,DFN,"DATA",DNAME)) Q:DNAME=""  D
-	..S DNAMEL(DNAME)=""
-	..S VALUE=^TMP($J,NODE,DFN,"DATA",DNAME)
-	..S DCNT=DCNT+1
-	..S ^PXRMXP(810.5,LIST,30,CNT,"DATA",DCNT,0)=DNAME_U_VALUE
-	..S ^PXRMXP(810.5,LIST,30,CNT,"DATA","B",DNAME,DCNT)=""
-	.S ^PXRMXP(810.5,LIST,30,CNT,1,0)=U_"810.531A"_U_DCNT_U_DCNT
-	S ^PXRMXP(810.5,LIST,30,0)=U_"810.53P"_U_CNT_U_CNT
-	;
-	;Save the reminder information
-	S RNCNT=0,RIEN=0
-	F  S RIEN=$O(RNAMEL(RIEN)) Q:RIEN'>0  D
-	.S RNCNT=RNCNT+1
-	.S ^PXRMXP(810.5,LIST,45,RCNT,0)=RIEN
-	.S ^PXRMXP(810.5,LIST,45,"B",RIEN,RNCNT)=""
-	I RNCNT>0 S ^PXRMXP(810.5,LIST,45,0)=U_"810.545P"_U_RNCNT_U_RNCNT
-	;
-	;Save the data types.
-	S DCNT=0,DNAME=""
-	F  S DNAME=$O(DNAMEL(DNAME)) Q:DNAME=""  D
-	.S DCNT=DCNT+1
-	.S ^PXRMXP(810.5,LIST,35,DCNT,0)=DNAME
-	.S ^PXRMXP(810.5,LIST,35,"B",DNAME,DCNT)=""
-	I DCNT>0 S ^PXRMXP(810.5,LIST,35,0)=U_"810.535A"_U_DCNT_U_DCNT
-	S ^PXRMXP(810.5,LIST,30,0)=U_"810.53P"_U_CNT_U_CNT
-	;
-	;Update header info
-	S TYPE=$S($G(PATCREAT)="Y":"PVT",1:"PUB")
-	K PATCREAT
-	S FDA(810.5,"?+1,",.01)=NAME
-	S FDA(810.5,"?+1,",.04)=$$NOW^XLFDT
-	S FDA(810.5,"?+1,",.05)=EPIEN
-	S FDA(810.5,"?+1,",.06)=RULE
-	S FDA(810.5,"?+1,",.07)=$G(DUZ)
-	S FDA(810.5,"?+1,",.08)=TYPE
-	I $G(INST)=1 S FDA(810.5,"?+1,",.1)=1
-	S FDA(810.5,"?+1,",50)=$S($G(PLISTPUG)="Y":1,1:0)
-	D UPDATE^DIE("","FDA","","MSG")
-	;Error
-	I $D(MSG) D ERR^PXRMRUL1
-	;Unlock patient list
-	D UNLOCK^PXRMRUL1
-	Q
-	;
+PXRMRULE ; SLC/PJH - Build Patient list from Rule Set ;08/11/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ; 
+ ; Called from PXRM PATIENT LIST CREATE protocol
+ ;
+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
+ ;
+CLEAR(RULE,NODE) ;Clear workfile entries
+ N SEQ
+ S SEQ=""
+ F  S SEQ=$O(^PXRM(810.4,RULE,30,"B",SEQ)) Q:'SEQ  D
+ .K ^TMP($J,NODE_SEQ)
+ ;clear FDA array
+ K ^TMP($J,"PXRMFDA")
+ 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
+ ;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
+ D UPDATE^DIE("","FDA","FDAIEN","MSG")
+ ;Error
+ I $D(MSG) Q 0
+ ;Otherwise list ien
+ Q FDAIEN(1)
+ ;
+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
+ ;
+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
+ ;
+INTR ;Input transform for #810.4 fields
+ Q
+ ;
+LOAD(NODE,LIEN) ;Load Patient List
+ N DATA,DFN,SUB
+ S SUB=0
+ F  S SUB=$O(^PXRMXP(810.5,LIEN,30,SUB)) Q:'SUB  D
+ .S DATA=$G(^PXRMXP(810.5,LIEN,30,SUB,0)),DFN=$P(DATA,U) Q:'DFN
+ .;Store the patient IEN and institution in ^TMP
+ .S ^TMP($J,NODE,DFN)=$P(DATA,U,2)_U_$P($G(DATA),U,3)_U_$P($G(DATA),U,4)
+ Q
+ ;
+LOCK L +^PXRMXP(810.5,LIST):0
+ E  W !!?5,"Another user is using this patient list" S DUOUT=1
+ Q
+ ;
+PATS(LIST) ;Process Patient List finding rule
+ ;
+ N LIEN,LUVALUE
+ ;Insert year and period into extract list name
+ I YEAR]"",LIST["yyyy" S LIST=$P(LIST,"yyyy")_YEAR_$P(LIST,"yyyy",2)
+ I PERIOD]"",LIST["nn" S LIST=$P(LIST,"nn")_$E(PERIOD,2,10)_$P(LIST,"nn",2)
+ ;
+ S LUVALUE(1)=LIST
+ S LIEN=+$$FIND1^DIC(810.5,"","KUX",.LUVALUE) Q:'LIEN
+ ;
+ ;Add operation Load list
+ I FRACT="A" D LOAD(FROUT,LIEN) Q
+ ;
+ ;Remove, Select or Add Findings operations
+ I FRACT'="A" D  Q
+ .;Load List
+ .D LOAD(PNODE,LIEN)
+ .;Check each patient
+ .S DFN=0
+ .F  S DFN=$O(^TMP($J,FROUT,DFN)) Q:'DFN  D
+ ..;Delete any ^TMP patient in PLIST if action is remove
+ ..I FRACT="R",$D(^TMP($J,PNODE,DFN)) K ^TMP($J,FROUT,DFN) Q
+ ..;Delete any ^TMP patient not in PLIST if action is select
+ ..I FRACT="S",'$D(^TMP($J,PNODE,DFN)) K ^TMP($J,FROUT,DFN)
+ Q
+ ;
+START(RULESET,LIST,NODE,LBBDT,LBEDT,PAR,YEAR,PERIOD,INDP,INTP) ;
+ ;Process rule set
+ ;Clear ^TMP
+ D CLEAR(RULESET,NODE)
+ ;
+ N CLASS,FRACT,FRDATA,FRDATES,FRIEN,FRLST,FRLIEN,FROLST,FROUT,FRPAT
+ N FRPERM,FRSTRT,FRTIEN,FRTYP,FSEQ,INC,INST,PXRMDATE
+ N RBDT,REDT,RRIEN,RSDATA,RSDATES,SEQ,SUB
+ ;Get class from extract parameter
+ I PAR S CLASS=$P($G(^PXRM(810.2,PAR,100)),U)
+ ;Otherwise default to local
+ I $G(CLASS)="" S CLASS="L"
+ ;Get each finding rule in sequence
+ S SEQ="",INC=0
+ F  S SEQ=$O(^PXRM(810.4,RULESET,30,"B",SEQ)) Q:'SEQ  D
+ .;Save first sequence as default
+ .I INC=0 S INC=1,FSEQ=SEQ
+ .S SUB=$O(^PXRM(810.4,RULESET,30,"B",SEQ,"")) Q:'SUB
+ .S RSDATA=$G(^PXRM(810.4,RULESET,30,SUB,0)) Q:RSDATA=""
+ .S RSDATES=$G(^PXRM(810.4,RULESET,30,SUB,1))
+ .;Finding rule ien and action
+ .S FRIEN=$P(RSDATA,U,2),FRACT=$P(RSDATA,U,3) Q:'FRIEN  Q:FRACT=""
+ .;Check if entry is a finding rule (not a set or reminder rule)
+ .S FRDATA=$G(^PXRM(810.4,FRIEN,0)),FRTYP=$P(FRDATA,U,3) Q:FRTYP=3
+ .S FRDATES=$P(FRDATA,U,4,5)
+ .;Get term IEN for finding rule
+ .I FRTYP=1 S FRTIEN=$P(FRDATA,U,7) Q:'FRTIEN
+ .;Get Reminder definition IEN for Reminder rule
+ .I FRTYP=2 S RRIEN=$P(FRDATA,U,10) Q:'RRIEN
+ .;Get Extract Patient List name for patient list rule
+ .I FRTYP=5 S FRLST=$P($G(^PXRM(810.4,FRIEN,1)),U) D  Q:FRLST=""
+ ..S FROLST=$P(FRDATA,U,8)
+ ..I +FROLST>0 S FRLST=$P($G(^PXRMXP(810.5,FROLST,0)),U)
+ .;Determine RBDT and REDT
+ .D RDATES^PXRMEUT1(RSDATES,FRDATES,LBBDT,LBEDT,.RBDT,.REDT)
+ .S PXRMDATE=LBEDT
+ .;Get start sequence or start patient list
+ .S FRSTRT=$P(RSDATA,U,4),FRPAT=$P(RSDATA,U,5)
+ .;If sequence is defined use it
+ .I FRSTRT S FROUT=NODE_FRSTRT
+ .;If neither exist use first as default
+ .I FRSTRT="",FRPAT="" S FROUT=NODE_FSEQ
+ .;If start is patient list load patient list into workfile
+ .I FRSTRT="",FRPAT]"" S FROUT=NODE_SEQ D LOAD(FROUT,FRPAT)
+ .;Name of permanent list
+ .S FRPERM=$P(RSDATA,U,6)
+ .;
+ .;Build patient list in TMP
+ .N DFN,PNODE,TLIST
+ .S PNODE="PXRMEVAL"
+ .K ^TMP($J,PNODE)
+ .;Term finding rules
+ .I FRTYP=1 D TERM^PXRMRUL1(FRACT,FRTIEN,RBDT,REDT,PNODE,.INST)
+ .;Reminder Definition List Rule
+ .I FRTYP=2 D REM^PXRMRUL1(FRACT,RRIEN,RBDT,REDT,PNODE)
+ .;Patient list finding rules
+ .I FRTYP=5 D PATS(FRLST)
+ .;Clear results file
+ .K ^TMP($J,PNODE)
+ .;
+ .;Build permanent list if required
+ .I FRPERM]"" D
+ ..N FRPIEN
+ ..;Get patient list IEN or create new patient list
+ ..S FRPIEN=$$CRLST(FRPERM,CLASS) Q:'FRPIEN
+ ..;Update patient list
+ ..D UPDLST(FROUT,FRPIEN,PAR,RULESET,INST)
+ ;
+ ;Save final results to patient list
+ I LIST'="",FROUT'="" D
+ . D RMPAT^PXRMEUT(FROUT,INDP,INTP)
+ . D UPDLST(FROUT,LIST,PAR,RULESET,INST)
+ . D DOCUMENT^PXRMEUT(LIST,RULESET,INDP,INTP,LBBDT,LBEDT)
+ Q
+ ;
+UPDLST(NODE,LIST,EPIEN,RULE,INST) ;Update patient list
+ N CNT,DA,DATA,DCNT,DFN,DNAME,DNAMEL,DUE,DUOUT,FDA,INST,INSTNAM,INSTNUM
+ N LAST,MSG,NAME,ONODE,RCNT,RIEN,RNAMEL,RNCNT,SUB,TEMP,TYPE,VALUE
+ ;Lock patient list
+ D LOCK Q:$D(DUOUT)
+ ;
+ ;Clear existing list.
+ K ^PXRMXP(810.5,LIST,30),^PXRMXP(810.5,LIST,35),^PXRMXP(810.5,LIST,45),^PXRMXP(810.5,LIST,200)
+ S NAME=$P($G(^PXRMXP(810.5,LIST,0)),U)
+ ;
+ ;Merge ^TMP into Patient List
+ S (CNT,DFN,INST)=0
+ F  S DFN=$O(^TMP($J,NODE,DFN)) Q:'DFN  D
+ .S ONODE=$G(^TMP($J,NODE,DFN,"INST"))
+ .S INSTNUM=$P(ONODE,U,1),INSTNAM=$P(ONODE,U,2)
+ .S CNT=CNT+1,^PXRMXP(810.5,LIST,30,CNT,0)=DFN_U_INSTNUM_U_INSTNAM
+ .S ^PXRMXP(810.5,LIST,30,"B",DFN,CNT)=""
+ .;
+ .;Save the reminder evaluation information only from Reports
+ .I $D(^TMP($J,NODE,DFN,"REM"))>0 D
+ ..S (RIEN,RCNT,RNCNT)=0
+ ..F  S RIEN=$O(^TMP($J,NODE,DFN,"REM",RIEN)) Q:RIEN'>0  D
+ ...S RNAMEL(RIEN)=""
+ ...S VALUE=^TMP($J,NODE,DFN,"REM",RIEN)
+ ...S RCNT=RCNT+1
+ ...S ^PXRMXP(810.5,LIST,30,CNT,"REM",RCNT,0)=VALUE
+ ...S ^PXRMXP(810.5,LIST,30,CNT,"REM","B",RIEN,RCNT)=""
+ ..S ^PXRMXP(810.5,LIST,30,CNT,1,0)=U_"810.532A"_U_RCNT_U_RCNT
+ .;
+ .I '$D(^TMP($J,NODE,DFN,"DATA")) Q
+ .S DCNT=0,DNAME=""
+ .F  S DNAME=$O(^TMP($J,NODE,DFN,"DATA",DNAME)) Q:DNAME=""  D
+ ..S DNAMEL(DNAME)=""
+ ..S VALUE=^TMP($J,NODE,DFN,"DATA",DNAME)
+ ..S DCNT=DCNT+1
+ ..S ^PXRMXP(810.5,LIST,30,CNT,"DATA",DCNT,0)=DNAME_U_VALUE
+ ..S ^PXRMXP(810.5,LIST,30,CNT,"DATA","B",DNAME,DCNT)=""
+ .S ^PXRMXP(810.5,LIST,30,CNT,1,0)=U_"810.531A"_U_DCNT_U_DCNT
+ S ^PXRMXP(810.5,LIST,30,0)=U_"810.53P"_U_CNT_U_CNT
+ ;
+ ;Save the reminder information
+ S RNCNT=0,RIEN=0
+ F  S RIEN=$O(RNAMEL(RIEN)) Q:RIEN'>0  D
+ .S RNCNT=RNCNT+1
+ .S ^PXRMXP(810.5,LIST,45,RCNT,0)=RIEN
+ .S ^PXRMXP(810.5,LIST,45,"B",RIEN,RNCNT)=""
+ I RNCNT>0 S ^PXRMXP(810.5,LIST,45,0)=U_"810.545P"_U_RNCNT_U_RNCNT
+ ;
+ ;Save the data types.
+ S DCNT=0,DNAME=""
+ F  S DNAME=$O(DNAMEL(DNAME)) Q:DNAME=""  D
+ .S DCNT=DCNT+1
+ .S ^PXRMXP(810.5,LIST,35,DCNT,0)=DNAME
+ .S ^PXRMXP(810.5,LIST,35,"B",DNAME,DCNT)=""
+ I DCNT>0 S ^PXRMXP(810.5,LIST,35,0)=U_"810.535A"_U_DCNT_U_DCNT
+ S ^PXRMXP(810.5,LIST,30,0)=U_"810.53P"_U_CNT_U_CNT
+ ;
+ ;Update header info
+ S TYPE=$S($G(PATCREAT)="Y":"PVT",1:"PUB")
+ K PATCREAT
+ S FDA(810.5,"?+1,",.01)=NAME
+ S FDA(810.5,"?+1,",.04)=$$NOW^XLFDT
+ S FDA(810.5,"?+1,",.05)=EPIEN
+ S FDA(810.5,"?+1,",.06)=RULE
+ S FDA(810.5,"?+1,",.07)=$G(DUZ)
+ S FDA(810.5,"?+1,",.08)=TYPE
+ I $G(INST)=1 S FDA(810.5,"?+1,",.1)=1
+ S FDA(810.5,"?+1,",50)=$S($G(PLISTPUG)="Y":1,1:0)
+ D UPDATE^DIE("","FDA","","MSG")
+ ;Error
+ I $D(MSG) D ERR
+ ;Unlock patient list
+ D UNLOCK
+ Q
+ ;
+UNLOCK L -^PXRMXP(810.5,LIST) Q
+ ;
