Context Navigation

← Previous Change
Next Change →

PXRMRULE.m

Timestamp:

Dec 4, 2009, 12:11:15 AM (14 years ago)

Author:

George Lilly

Message:

revised back to 6/30/08 version

File:

: 1 edited

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMRULE.m (modified) (1 diff)

Legend:

: Unmodified
: Added
: Removed

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMRULE.m

-              r613
+              r623
+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
+ ;

Note: See TracChangeset for help on using the changeset viewer.

Context Navigation

Changeset 623 for WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMRULE.m

Legend:

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMRULE.m

Download in other formats: