Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PXRMRULE

PXRMRULE.m

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