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
 ;