Changeset 636 for FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMRULE.m

Timestamp:

Dec 4, 2009, 8:26:01 PM (14 years ago)

Author:

George Lilly

Message:

WorldVistAEHR overlayed on FOIAVistA

Location:

FOIAVistA/tag/r

Files:

• . (copied) (copied from FOIAVistA/trunk/r )
• CLINICAL_REMINDERS-PXRM/PXRMRULE.m (modified) (10 diffs)

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMRULE.m

@@ -1 @@
-PXRMRULE ; SLC/PJH - Build Patient list from Rule Set ;03/27/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+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
@@ -13 +27 @@
  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
@@ -25 +115 @@
  Q
  ;
-PATS(FRACT,FROUT,PNODE,LIST) ;Process Patient List finding rule
+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
@@ -38 +132 @@
  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) ;
+ ;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
@@ -56 +151 @@
  ;
  N CLASS,FRACT,FRDATA,FRDATES,FRIEN,FRLST,FRLIEN,FROLST,FROUT,FRPAT
- N FRPERM,FRSTRT,FRTIEN,FRTYP,FSEQ,INC,INST,PXRMDATE,PXRMDDOC
+ N FRPERM,FRSTRT,FRTIEN,FRTYP,FSEQ,INC,INST,PXRMDATE
  N RBDT,REDT,RRIEN,RSDATA,RSDATES,SEQ,SUB
  ;Get class from extract parameter
@@ -62 +157 @@
  ;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
+ S SEQ="",INC=0
  F  S SEQ=$O(^PXRM(810.4,RULESET,30,"B",SEQ)) Q:'SEQ  D
  .;Save first sequence as default
@@ -84 +176 @@
  .;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)
@@ -106 +197 @@
  .K ^TMP($J,PNODE)
  .;Term finding rules
- .I FRTYP=1 D TERM^PXRMRUL1(FRACT,FRTIEN,LBBDT,LBEDT,RBDT,REDT,PNODE,.INST)
+ .I FRTYP=1 D TERM^PXRMRUL1(FRACT,FRTIEN,RBDT,REDT,PNODE,.INST)
  .;Reminder Definition List Rule
- .I FRTYP=2 D REM^PXRMRUL1(FRACT,RRIEN,LBBDT,LBEDT,RBDT,REDT,PNODE)
+ .I FRTYP=2 D REM^PXRMRUL1(FRACT,RRIEN,RBDT,REDT,PNODE)
  .;Patient list finding rules
- .I FRTYP=5 D PATS(FRACT,FROUT,PNODE,FRLST)
+ .I FRTYP=5 D PATS(FRLST)
  .;Clear results file
  .K ^TMP($J,PNODE)
@@ -118 +209 @@
  ..N FRPIEN
  ..;Get patient list IEN or create new patient list
- ..S FRPIEN=$$CRLST^PXRMRUL1(FRPERM,CLASS) Q:'FRPIEN
+ ..S FRPIEN=$$CRLST(FRPERM,CLASS) Q:'FRPIEN
  ..;Update patient list
- ..D UPDLST(FROUT,FRPIEN,PAR,RULESET,INST,INDP,INTP)
+ ..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,INDP,INTP)
- .;PXRMDDOC=2 compare saved dates with those generated in
- .;DOCUMENT^PXRMEUT.
- . S PXRMDDOC=2
+ . D UPDLST(FROUT,LIST,PAR,RULESET,INST)
  . 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
+ 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^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
+ 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 (DECEASED,TESTP)=""
- S (CNT,DFN)=0
+ 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 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 CNT=CNT+1,^PXRMXP(810.5,LIST,30,CNT,0)=DFN_U_INSTNUM_U_INSTNAM
  .S ^PXRMXP(810.5,LIST,30,"B",DFN,CNT)=""
  .;
@@ -215 +290 @@
  D UPDATE^DIE("","FDA","","MSG")
  ;Error
- I $D(MSG) D ERR^PXRMRUL1
+ I $D(MSG) D ERR
  ;Unlock patient list
- D UNLOCK^PXRMRUL1
- Q
- ;
+ D UNLOCK
+ Q
+ ;
+UNLOCK L -^PXRMXP(810.5,LIST) Q
+ ;