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

PXRMPLST.m

Go to the documentation of this file. 
  1. PXRMPLST ;SLC/PKR - Build a patient list from a reminder definition. ;08/17/2017
  1.  ;;2.0;CLINICAL REMINDERS;**4,6,18,42**;Feb 04, 2005;Build 245
  1.  ;
  1.  ;Input  :  DEFARR   - Reminder definition
  1.  ;          PLIST    - List returned in ^TMP($J,PLIST,DFN)
  1.  ;          DFNONLY  - If true list contains only DFN information
  1.  ;          PXRMDATE - Evaluation date
  1.  ;===================================================
  1. BLDPLST(DEFARR,PLIST,DFNONLY) ;
  1.  N DFN,DOBE,DOBS,ELE,ERROR,ERRSTR,IND,FNUM
  1.  N LIST1,LIST2,LNAME,LSP,LSTACK
  1.  N NDR,NOT,OPER,PCLOG,PFSTACK,SEX,TYPE
  1.  ;
  1.  ;Get the cohort logic string. This has passed a validation before
  1.  ;it can be selected for building patient lists so we don't need to
  1.  ;check it here.
  1.  S PCLOG=DEFARR(31)
  1.  I PCLOG="" Q
  1.  S OPER="!&~"
  1.  ;Get the sex field, if PCLOG does not contain SEX set it to null.
  1.  S SEX=$S(PCLOG["SEX":$P(DEFARR(0),U,9),1:"")
  1.  ;If PCLOG contains age build the corresponding date of birth range(s).
  1.  I PCLOG["AGE" D DOBR(.DEFARR,.NDR,.DOBS,.DOBE)
  1.  ;Replace &' with ~ so the stack will be built properly.
  1.  S PCLOG=$$STRREP^PXRMUTIL(PCLOG,"&'","~")
  1.  D POSTFIX^PXRMSTAC(PCLOG,OPER,.PFSTACK)
  1.  ;Process the logic.
  1.  D CFSAA(.PFSTACK)
  1.  S (IND,ERROR,LSP,LSTACK(0),NOT)=0
  1.  F  Q:(IND'<PFSTACK(0))!(ERROR)  D
  1.  . S IND=IND+1,ELE=PFSTACK(IND)
  1.  . I ELE["'" S NOT=1
  1.  . S TYPE=$S(ELE="'":"NOT",ELE["AGE":"A",ELE["FI":"FI",ELE["FF":"FF",ELE="SAA":"SAA",ELE["SEX":"S",OPER[ELE:"OP",1:"")
  1.  .;
  1.  . I TYPE="A" D  Q
  1.  .. S LNAME="LIST"_IND
  1.  .. D LSA("",NDR,.DOBS,.DOBE,LNAME)
  1.  .. D PUSH^PXRMSTAC(.LSTACK,LNAME)
  1.  .. D AGEFI(.DEFARR,LNAME,SEX,"")
  1.  .;
  1.  . I TYPE="FI" D  Q
  1.  .. S IND=IND+1,FNUM=PFSTACK(IND)
  1.  .. I +FNUM'=FNUM S ERROR=1,ERRSTR="Error - having a finding not followed by a number" Q
  1.  .. S LNAME="LIST"_IND
  1.  .. D EVALPL^PXRMEVFI(.DEFARR,FNUM,LNAME)
  1.  .. D PUSH^PXRMSTAC(.LSTACK,LNAME)
  1.  .;
  1.  . I TYPE="FF" D  Q
  1.  .. S IND=IND+1,FNUM=PFSTACK(IND)
  1.  .. I +FNUM'=FNUM S ERROR=1,ERRSTR="Error - having a function finding not followed by a number"
  1.  .. S LNAME="LIST"_IND
  1.  .. D EVALPL^PXRMFF(.DEFARR,"FF"_FNUM,LNAME)
  1.  .. D PUSH^PXRMSTAC(.LSTACK,LNAME)
  1.  .;
  1.  . I TYPE="NOT" S NOT=1 Q 
  1.  .;
  1.  . I TYPE="OP" D  Q
  1.  .. S LIST2=$$POP^PXRMSTAC(.LSTACK)
  1.  .. S LIST1=$$POP^PXRMSTAC(.LSTACK)
  1.  .. I NOT S ELE=ELE_"'",NOT=0
  1.  .. D LOGOP(LIST1,LIST2,ELE)
  1.  .. D PUSH^PXRMSTAC(.LSTACK,LIST1)
  1.  .. K ^TMP($J,LIST2)
  1.  .;
  1.  . I TYPE="S" D  Q
  1.  .. S LNAME="LIST"_IND
  1.  .. D LSEX(SEX,LNAME,.LSTACK)
  1.  .. D PUSH^PXRMSTAC(.LSTACK,LNAME)
  1.  .;
  1.  . I TYPE="SAA" D  Q
  1.  .. S LNAME="LIST"_IND
  1.  .. D LSA(SEX,NDR,.DOBS,.DOBE,LNAME)
  1.  .. D PUSH^PXRMSTAC(.LSTACK,LNAME)
  1.  .. D AGEFI(.DEFARR,LNAME,SEX,"")
  1.  .;
  1.  S LIST1=$$POP^PXRMSTAC(.LSTACK)
  1.  ;If AGE is not in the cohort logic look for any findings that set the
  1.  ;frequency to 0Y and therefore remove the patient from the cohort.
  1.  I PCLOG'["AGE" D AGEFI(.DEFARR,LIST1,"","0Y")
  1.  ;
  1.  I $G(DFNONLY) D
  1.  . S DFN=0
  1.  . F  S DFN=$O(^TMP($J,LIST1,1,DFN)) Q:DFN=""  D
  1.  .. S ^TMP($J,PLIST,DFN)=""
  1.  E  M ^TMP($J,PLIST)=^TMP($J,LIST1)
  1.  K ^TMP($J,LIST1)
  1.  Q
  1.  ;
  1.  ;==================================================
  1. AGEFI(DEFARR,LNAME,SEX,ONLYFREQ) ;Check for patients that need to be
  1.  ;added or removed because of a finding that changes the age range.
  1.  N DEL,DFN,DOB,DOBE,DOBS,FILIST,FINUM,FREQ,IND,JND,LOGOP
  1.  N MINAGE,MAXAGE,NUMAFI,PSEX,RANK,RANKARR,RF,TEMP,TGLIST
  1.  S NUMAFI=$P(DEFARR(40),U,1)
  1.  I NUMAFI=0 Q
  1.  S FILIST=$P(DEFARR(40),U,2)
  1.  F IND=1:1:NUMAFI D
  1.  . S FINUM=$P(FILIST,";",IND)
  1.  . S TEMP=$S(FINUM["FF":DEFARR(25,FINUM,0),1:DEFARR(20,FINUM,0))
  1.  . S RANK=+$P(TEMP,U,5)
  1.  . I RANK=0 S RANK=9999
  1.  . S FREQ=$$FRQINDAY^PXRMDATE($P(TEMP,U,4))
  1.  .;If there is no frequency with this rank ignore it.
  1.  . I FREQ]"" S RANKARR(RANK,FREQ,FINUM)=""
  1.  S IND=0,RANK=""
  1.  F  S RANK=$O(RANKARR(RANK)) Q:RANK=""  D
  1.  . S FREQ=""
  1.  . F  S FREQ=$O(RANKARR(RANK,FREQ)) Q:FREQ=""  D
  1.  .. S FINUM=0
  1.  .. F  S FINUM=$O(RANKARR(RANK,FREQ,FINUM)) Q:FINUM=""  D
  1.  ... S IND=IND+1,RF(IND)=FINUM
  1.  I IND'=NUMAFI W !,"Error in AGEFI^PXRMPLST - Ranking failed!"
  1.  ;Build a list for each age finding.
  1.  F IND=1:1:NUMAFI D
  1.  . S FINUM=RF(IND)
  1.  . S TGLIST="AGEFI"_FINUM
  1.  . S TEMP=$S(FINUM["FF":DEFARR(25,FINUM,0),1:DEFARR(20,FINUM,0))
  1.  . S FREQ=$P(TEMP,U,4)
  1.  . I ONLYFREQ="0Y",FREQ'="0Y" S LOGOP(IND)="~" Q
  1.  . S LOGOP(IND)=$S(FREQ="0Y":"~",FREQ="":"~",1:"!")
  1.  . S MINAGE=$P(TEMP,U,2)
  1.  . S MAXAGE=$P(TEMP,U,3)
  1.  . S DOBE=$S(MINAGE="":$$NOW^PXRMDATE,1:$$GETDOB(MINAGE,"MIN"))
  1.  . S DOBS=$S(MAXAGE="":0,1:$$GETDOB(MAXAGE,"MAX"))
  1.  . K ^TMP($J,TGLIST)
  1.  . I FINUM=+FINUM D EVALPL^PXRMEVFI(.DEFARR,FINUM,TGLIST)
  1.  . I FINUM["FF" D EVALPL^PXRMFF(.DEFARR,FINUM,TGLIST)
  1.  .;Filter TGLIST based on the age range.
  1.  . S DFN=$S(FREQ="0Y":$O(^TMP($J,TGLIST,1,""),-1),1:0)
  1.  . F  S DFN=$O(^TMP($J,TGLIST,1,DFN)) Q:DFN=""  D
  1.  .. S DEL=0
  1.  ..;Reference to ^DPT DBIA #10035
  1.  .. S PSEX=$P(^DPT(DFN,0),U,2),DOB=$P(^DPT(DFN,0),U,3)
  1.  .. I SEX'="",PSEX'=SEX S DEL=1
  1.  .. I (DOB<DOBS)!(DOB>DOBE) S DEL=1
  1.  .. I DEL K ^TMP($J,TGLIST,0,DFN),^TMP($J,TGLIST,1,DFN)
  1.  ;Remove patients on a list with a higher rank from all lists with
  1.  ;a lower rank.
  1.  F IND=1:1:NUMAFI D
  1.  . F JND=IND+1:1:NUMAFI D LOGOP("AGEFI"_RF(JND),"AGEFI"_RF(IND),"~")
  1.  F IND=1:1:NUMAFI D
  1.  . D LOGOP(LNAME,"AGEFI"_RF(IND),LOGOP(IND))
  1.  . K ^TMP($J,"AGEFI"_RF(IND))
  1.  Q
  1.  ;
  1.  ;==================================================
  1. CFSAA(STACK) ;Check for the first three elements on the stack being
  1.  ;SEX, AGE, and &. If that is the case replace them with the "special"
  1.  ;finding SAA.
  1.  N EL1,EL2,EL3,SAA
  1.  S SAA=0
  1.  S EL1=$G(STACK(1)),EL2=$G(STACK(2)),EL3=$G(STACK(3))
  1.  I EL1="SEX",EL2="AGE",EL3="&" S SAA=1
  1.  I EL1="AGE",EL2="SEX",EL3="&" S SAA=1
  1.  I 'SAA Q
  1.  ;Create a new pseudo-element for SEX&AGE.
  1.  S EL1=$$POP^PXRMSTAC(.STACK)
  1.  S EL1=$$POP^PXRMSTAC(.STACK)
  1.  S EL1=$$POP^PXRMSTAC(.STACK)
  1.  D PUSH^PXRMSTAC(.STACK,"SAA")
  1.  Q
  1.  ;
  1.  ;==================================================
  1. DOBR(DEFARR,NDR,DOBS,DOBE) ;Build the date of birth range.
  1.  N IND,FREQ,MINAGE,MAXAGE,TEMP
  1.  S (IND,NDR)=0
  1.  F  S IND=+$O(DEFARR(7,IND)) Q:IND=0  D
  1.  . S TEMP=DEFARR(7,IND,0)
  1.  . S FREQ=$P(TEMP,U,1)
  1.  . I (FREQ="0Y")!(FREQ="") Q
  1.  . S MINAGE=$P(TEMP,U,2)
  1.  . S MAXAGE=$P(TEMP,U,3)
  1.  . S NDR=NDR+1
  1.  . S DOBE(NDR)=$S(MINAGE="":$$NOW^PXRMDATE,1:$$GETDOB(MINAGE,"MIN"))
  1.  . S DOBS(NDR)=$S(MAXAGE="":0,1:$$GETDOB(MAXAGE,"MAX"))
  1.  Q
  1.  ;
  1.  ;==================================================
  1. GENTERM(FINDING,FINUM,TERMARR) ;Given a reminder finding generate a term
  1.  ;for patient list evaluation.
  1.  N IEN,IND,TEMP,TYPE
  1.  K TERMARR
  1.  S TEMP=$P(FINDING,U,1)
  1.  S IEN=$P(TEMP,";",1)
  1.  S TYPE=$P(TEMP,";",2)
  1.  ;If the finding is a term just load the term.
  1.  I TYPE="PXRMD(811.5," D TERM^PXRMLDR(IEN,.TERMARR) Q
  1.  S TERMARR(0)="GENERATED"
  1.  S TERMARR("IEN")=0
  1.  M TERMARR(20,1)=DEFARR(20,FINUM)
  1.  S TERMARR("E",TYPE,IEN,1)=""
  1.  Q
  1.  ;
  1.  ;==================================================
  1. GETDOB(AGE,TYPE) ;Given an age in years return the corresponding date of
  1.  ;birth. If TYPE is MIN then find the date of birth that will make them
  1.  ;that age. If TYPE is MAX find the last day that will make them
  1.  ;that age, i.e., the next day is their birthday.
  1.  N DATE,DOB
  1.  S DATE=$$NOW^PXRMDATE
  1.  I TYPE="MIN" S DOB=DATE-(10000*AGE)
  1.  I TYPE="MAX" S DOB=DATE-(10000*(AGE+1)),DOB=$$FMADD^XLFDT(DOB,1)
  1.  Q DOB
  1.  ;
  1.  ;==================================================
  1. LOGOP(LIST1,LIST2,LOGOP) ;Given LIST1 and LIST2 apply the logical
  1.  ;operator LOGOP to generate a new list and return it in LIST1
  1.  N DFN1,DFN2
  1.  I LOGOP="&" D  Q
  1.  . S DFN1=""
  1.  . F  S DFN1=$O(^TMP($J,LIST1,1,DFN1)) Q:DFN1=""  D
  1.  .. I $D(^TMP($J,LIST2,1,DFN1)) M ^TMP($J,LIST1,1,DFN1)=^TMP($J,LIST2,1,DFN1) Q
  1.  .. K ^TMP($J,LIST1,1,DFN1)
  1.  ;
  1.  ;"~" represents "&'".
  1.  I LOGOP="~" D  Q
  1.  . S DFN1=""
  1.  . F  S DFN1=$O(^TMP($J,LIST1,1,DFN1)) Q:DFN1=""  D
  1.  .. I $D(^TMP($J,LIST2,1,DFN1)) K ^TMP($J,LIST1,1,DFN1)
  1.  ;
  1.  I LOGOP="!" D
  1.  . S DFN2=""
  1.  . F  S DFN2=$O(^TMP($J,LIST2,1,DFN2)) Q:DFN2=""  D
  1.  .. M ^TMP($J,LIST1,1,DFN2)=^TMP($J,LIST2,1,DFN2)
  1.  Q
  1.  ;
  1.  ;==================================================
  1. LSA(SEX,NDR,DOBS,DOBE,LNAME) ;Build a list from a SEX & AGE finding.
  1.  ;Reference to ^DPT DBIA #10035
  1.  N DFN,DS,IND,SEXOK
  1.  F IND=1:1:NDR D
  1.  . S DS=DOBS(IND)-.000001
  1.  . F  S DS=$O(^DPT("ADOB",DS)) Q:(DS>DOBE(IND))!(DS="")  D
  1.  .. S DFN=""
  1.  .. F  S DFN=$O(^DPT("ADOB",DS,DFN)) Q:DFN=""  D
  1.  ... S SEXOK=$S(SEX="":1,$D(^DPT("ASX",SEX,DFN)):1,1:0)
  1.  ... I SEXOK S ^TMP($J,LNAME,1,DFN,1,"SAA")=""
  1.  Q
  1.  ;
  1.  ;==================================================
  1. LSEX(SEX,LNAME,LSTACK) ;Build a list from a SEX finding.
  1.  ;Reference to ^DPT DBIA #10035
  1.  N ELIST
  1.  ;Start with the existing list to build a list based on sex.
  1.  S ELIST=$$POP^PXRMSTAC(.LSTACK)
  1.  D PUSH^PXRMSTAC(.LSTACK,ELIST)
  1.  S DFN=0
  1.  F  S DFN=$O(^TMP($J,ELIST,1,DFN)) Q:DFN=""  D
  1.  . I $D(^DPT("ASX",SEX,DFN)) S ^TMP($J,LNAME,1,DFN,SEX,1)=""
  1.  Q
  1.  ;