PXRMPLST ;SLC/PKR - Build a patient list from a reminder definition. ;09/23/2010
;;2.0;CLINICAL REMINDERS;**4,6,18**;Feb 04, 2005;Build 152
;
;Input : RIEN - Reminder IEN
; PLIST - List returned in ^TMP($J,PLIST,DFN)
; DFNONLY - If true list contains only DFN information
; PXRMDATE - Evaluation date
;===================================================
BLDPLST(DEFARR,PLIST,DFNONLY) ;
N DFN,DOBE,DOBS,ELE,ERROR,ERRSTR,IND,FNUM
N LIST1,LIST2,LNAME,LSP,LSTACK
N NDR,NOT,OPER,PCLOG,PFSTACK,SEX,TYPE
;
;Get the cohort logic string. This has passed a validation before
;it can be selected for building patient lists so we don't need to
;check it here.
S PCLOG=DEFARR(31)
I PCLOG="" Q
S OPER="!&~"
;Get the sex field, if PCLOG does not contain SEX set it to null.
S SEX=$S(PCLOG["SEX":$P(DEFARR(0),U,9),1:"")
;If PCLOG contains age build the corresponding date of birth range(s).
I PCLOG["AGE" D DOBR(.DEFARR,.NDR,.DOBS,.DOBE)
;Replace &' with ~ so the stack will be built properly.
S PCLOG=$$STRREP^PXRMUTIL(PCLOG,"&'","~")
D POSTFIX^PXRMSTAC(PCLOG,OPER,.PFSTACK)
;Process the logic.
D CFSAA(.PFSTACK)
S (IND,ERROR,LSP,LSTACK(0),NOT)=0
F Q:(IND'<PFSTACK(0))!(ERROR) D
. S IND=IND+1,ELE=PFSTACK(IND)
. I ELE["'" S NOT=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:"")
.;
. I TYPE="A" D Q
.. S LNAME="LIST"_IND
.. D LSA("",NDR,.DOBS,.DOBE,LNAME)
.. D PUSH^PXRMSTAC(.LSTACK,LNAME)
.. D AGEFI(.DEFARR,LNAME,SEX,"")
.;
. I TYPE="FI" D Q
.. S IND=IND+1,FNUM=PFSTACK(IND)
.. I +FNUM'=FNUM S ERROR=1,ERRSTR="Error - having a finding not followed by a number" Q
.. S LNAME="LIST"_IND
.. D EVALPL^PXRMEVFI(.DEFARR,FNUM,LNAME)
.. D PUSH^PXRMSTAC(.LSTACK,LNAME)
.;
. I TYPE="FF" D Q
.. S IND=IND+1,FNUM=PFSTACK(IND)
.. I +FNUM'=FNUM S ERROR=1,ERRSTR="Error - having a function finding not followed by a number"
.. S LNAME="LIST"_IND
.. D EVALPL^PXRMFF(.DEFARR,"FF"_FNUM,LNAME)
.. D PUSH^PXRMSTAC(.LSTACK,LNAME)
.;
. I TYPE="NOT" S NOT=1 Q
.;
. I TYPE="OP" D Q
.. S LIST2=$$POP^PXRMSTAC(.LSTACK)
.. S LIST1=$$POP^PXRMSTAC(.LSTACK)
.. I NOT S ELE=ELE_"'",NOT=0
.. D LOGOP(LIST1,LIST2,ELE)
.. D PUSH^PXRMSTAC(.LSTACK,LIST1)
.. K ^TMP($J,LIST2)
.;
. I TYPE="S" D Q
.. S LNAME="LIST"_IND
.. D LSEX(SEX,LNAME,.LSTACK)
.. D PUSH^PXRMSTAC(.LSTACK,LNAME)
.;
. I TYPE="SAA" D Q
.. S LNAME="LIST"_IND
.. D LSA(SEX,NDR,.DOBS,.DOBE,LNAME)
.. D PUSH^PXRMSTAC(.LSTACK,LNAME)
.. D AGEFI(.DEFARR,LNAME,SEX,"")
.;
S LIST1=$$POP^PXRMSTAC(.LSTACK)
;If AGE is not in the cohort logic look for any findings that set the
;frequency to 0Y and therefore remove the patient from the cohort.
I PCLOG'["AGE" D AGEFI(.DEFARR,LIST1,"","0Y")
;
I $G(DFNONLY) D
. S DFN=0
. F S DFN=$O(^TMP($J,LIST1,1,DFN)) Q:DFN="" D
.. S ^TMP($J,PLIST,DFN)=""
E M ^TMP($J,PLIST)=^TMP($J,LIST1)
K ^TMP($J,LIST1)
Q
;
;==================================================
AGEFI(DEFARR,LNAME,SEX,ONLYFREQ) ;Check for patients that need to be
;added or removed because of a finding that changes the age range.
N DEL,DFN,DOB,DOBE,DOBS,FILIST,FINUM,FREQ,IND,JND,LOGOP
N MINAGE,MAXAGE,NUMAFI,PSEX,RANK,RANKARR,RF,TEMP,TGLIST
S NUMAFI=$P(DEFARR(40),U,1)
I NUMAFI=0 Q
S FILIST=$P(DEFARR(40),U,2)
F IND=1:1:NUMAFI D
. S FINUM=$P(FILIST,";",IND)
. S TEMP=$S(FINUM["FF":DEFARR(25,FINUM,0),1:DEFARR(20,FINUM,0))
. S RANK=+$P(TEMP,U,5)
. I RANK=0 S RANK=9999
. S FREQ=$$FRQINDAY^PXRMDATE($P(TEMP,U,4))
.;If there is no frequency with this rank ignore it.
. I FREQ]"" S RANKARR(RANK,FREQ,FINUM)=""
S IND=0,RANK=""
F S RANK=$O(RANKARR(RANK)) Q:RANK="" D
. S FREQ=""
. F S FREQ=$O(RANKARR(RANK,FREQ)) Q:FREQ="" D
.. S FINUM=0
.. F S FINUM=$O(RANKARR(RANK,FREQ,FINUM)) Q:FINUM="" D
... S IND=IND+1,RF(IND)=FINUM
I IND'=NUMAFI W !,"Error in AGEFI^PXRMPLST - Ranking failed!"
;Build a list for each age finding.
F IND=1:1:NUMAFI D
. S FINUM=RF(IND)
. S TGLIST="AGEFI"_FINUM
. S TEMP=$S(FINUM["FF":DEFARR(25,FINUM,0),1:DEFARR(20,FINUM,0))
. S FREQ=$P(TEMP,U,4)
. I ONLYFREQ="0Y",FREQ'="0Y" S LOGOP(IND)="~" Q
. S LOGOP(IND)=$S(FREQ="0Y":"~",FREQ="":"~",1:"!")
. S MINAGE=$P(TEMP,U,2)
. S MAXAGE=$P(TEMP,U,3)
. S DOBE=$S(MINAGE="":$$NOW^PXRMDATE,1:$$GETDOB(MINAGE,"MIN"))
. S DOBS=$S(MAXAGE="":0,1:$$GETDOB(MAXAGE,"MAX"))
. K ^TMP($J,TGLIST)
. I FINUM=+FINUM D EVALPL^PXRMEVFI(.DEFARR,FINUM,TGLIST)
. I FINUM["FF" D EVALPL^PXRMFF(.DEFARR,FINUM,TGLIST)
.;Filter TGLIST based on the age range.
. S DFN=$S(FREQ="0Y":$O(^TMP($J,TGLIST,1,""),-1),1:0)
. F S DFN=$O(^TMP($J,TGLIST,1,DFN)) Q:DFN="" D
.. S DEL=0
..;Reference to ^DPT DBIA #10035
.. S PSEX=$P(^DPT(DFN,0),U,2),DOB=$P(^DPT(DFN,0),U,3)
.. I SEX'="",PSEX'=SEX S DEL=1
.. I (DOB<DOBS)!(DOB>DOBE) S DEL=1
.. I DEL K ^TMP($J,TGLIST,0,DFN),^TMP($J,TGLIST,1,DFN)
;Remove patients on a list with a higher rank from all lists with
;a lower rank.
F IND=1:1:NUMAFI D
. F JND=IND+1:1:NUMAFI D LOGOP("AGEFI"_RF(JND),"AGEFI"_RF(IND),"~")
F IND=1:1:NUMAFI D
. D LOGOP(LNAME,"AGEFI"_RF(IND),LOGOP(IND))
. K ^TMP($J,"AGEFI"_RF(IND))
Q
;
;==================================================
CFSAA(STACK) ;Check for the first three elements on the stack being
;SEX, AGE, and &. If that is the case replace them with the "special"
;finding SAA.
N EL1,EL2,EL3,SAA
S SAA=0
S EL1=$G(STACK(1)),EL2=$G(STACK(2)),EL3=$G(STACK(3))
I EL1="SEX",EL2="AGE",EL3="&" S SAA=1
I EL1="AGE",EL2="SEX",EL3="&" S SAA=1
I 'SAA Q
;Create a new pseudo-element for SEX&AGE.
S EL1=$$POP^PXRMSTAC(.STACK)
S EL1=$$POP^PXRMSTAC(.STACK)
S EL1=$$POP^PXRMSTAC(.STACK)
D PUSH^PXRMSTAC(.STACK,"SAA")
Q
;
;==================================================
DOBR(DEFARR,NDR,DOBS,DOBE) ;Build the date of birth range.
N IND,FREQ,MINAGE,MAXAGE,TEMP
S (IND,NDR)=0
F S IND=+$O(DEFARR(7,IND)) Q:IND=0 D
. S TEMP=DEFARR(7,IND,0)
. S FREQ=$P(TEMP,U,1)
. I (FREQ="0Y")!(FREQ="") Q
. S MINAGE=$P(TEMP,U,2)
. S MAXAGE=$P(TEMP,U,3)
. S NDR=NDR+1
. S DOBE(NDR)=$S(MINAGE="":$$NOW^PXRMDATE,1:$$GETDOB(MINAGE,"MIN"))
. S DOBS(NDR)=$S(MAXAGE="":0,1:$$GETDOB(MAXAGE,"MAX"))
Q
;
;==================================================
GENTERM(FINDING,FINUM,TERMARR) ;Given a reminder finding generate a term
;for patient list evaluation.
N IEN,IND,TEMP,TYPE
K TERMARR
S TEMP=$P(FINDING,U,1)
S IEN=$P(TEMP,";",1)
S TYPE=$P(TEMP,";",2)
;If the finding is a term just load the term.
I TYPE="PXRMD(811.5," D TERM^PXRMLDR(IEN,.TERMARR) Q
S TERMARR(0)="GENERATED"
S TERMARR("IEN")=0
M TERMARR(20,1)=DEFARR(20,FINUM)
S TERMARR("E",TYPE,IEN,1)=""
Q
;
;==================================================
GETDOB(AGE,TYPE) ;Given an age in years return the corresponding date of
;birth. If TYPE is MIN then find the date of birth that will make them
;that age. If TYPE is MAX find the last day that will make them
;that age, i.e., the next day is their birthday.
N DATE,DOB
S DATE=$$NOW^PXRMDATE
I TYPE="MIN" S DOB=DATE-(10000*AGE)
I TYPE="MAX" S DOB=DATE-(10000*(AGE+1)),DOB=$$FMADD^XLFDT(DOB,1)
Q DOB
;
;==================================================
LOGOP(LIST1,LIST2,LOGOP) ;Given LIST1 and LIST2 apply the logical
;operator LOGOP to generate a new list and return it in LIST1
N DFN1,DFN2
I LOGOP="&" D Q
. S DFN1=""
. F S DFN1=$O(^TMP($J,LIST1,1,DFN1)) Q:DFN1="" D
.. I $D(^TMP($J,LIST2,1,DFN1)) M ^TMP($J,LIST1,1,DFN1)=^TMP($J,LIST2,1,DFN1) Q
.. K ^TMP($J,LIST1,1,DFN1)
;
;"~" represents "&'".
I LOGOP="~" D Q
. S DFN1=""
. F S DFN1=$O(^TMP($J,LIST1,1,DFN1)) Q:DFN1="" D
.. I $D(^TMP($J,LIST2,1,DFN1)) K ^TMP($J,LIST1,1,DFN1)
;
I LOGOP="!" D
. S DFN2=""
. F S DFN2=$O(^TMP($J,LIST2,1,DFN2)) Q:DFN2="" D
.. M ^TMP($J,LIST1,1,DFN2)=^TMP($J,LIST2,1,DFN2)
Q
;
;==================================================
LSA(SEX,NDR,DOBS,DOBE,LNAME) ;Build a list from a SEX & AGE finding.
;Reference to ^DPT DBIA #10035
N DFN,DS,IND,SEXOK
F IND=1:1:NDR D
. S DS=DOBS(IND)-.000001
. F S DS=$O(^DPT("ADOB",DS)) Q:(DS>DOBE(IND))!(DS="") D
.. S DFN=""
.. F S DFN=$O(^DPT("ADOB",DS,DFN)) Q:DFN="" D
... S SEXOK=$S(SEX="":1,$D(^DPT("ASX",SEX,DFN)):1,1:0)
... I SEXOK S ^TMP($J,LNAME,1,DFN,1,"SAA")=""
Q
;
;==================================================
LSEX(SEX,LNAME,LSTACK) ;Build a list from a SEX finding.
;Reference to ^DPT DBIA #10035
N ELIST
;Start with the existing list to build a list based on sex.
S ELIST=$$POP^PXRMSTAC(.LSTACK)
D PUSH^PXRMSTAC(.LSTACK,ELIST)
S DFN=0
F S DFN=$O(^TMP($J,ELIST,1,DFN)) Q:DFN="" D
. I $D(^DPT("ASX",SEX,DFN)) S ^TMP($J,LNAME,1,DFN,SEX,1)=""
Q
;
PXRMPLST ;SLC/PKR - Build a patient list from a reminder definition. ;09/23/2010
+1 ;;2.0;CLINICAL REMINDERS;**4,6,18**;Feb 04, 2005;Build 152
+2 ;
+3 ;Input : RIEN - Reminder IEN
+4 ; PLIST - List returned in ^TMP($J,PLIST,DFN)
+5 ; DFNONLY - If true list contains only DFN information
+6 ; PXRMDATE - Evaluation date
+7 ;===================================================
BLDPLST(DEFARR,PLIST,DFNONLY) ;
+1 NEW DFN,DOBE,DOBS,ELE,ERROR,ERRSTR,IND,FNUM
+2 NEW LIST1,LIST2,LNAME,LSP,LSTACK
+3 NEW NDR,NOT,OPER,PCLOG,PFSTACK,SEX,TYPE
+4 ;
+5 ;Get the cohort logic string. This has passed a validation before
+6 ;it can be selected for building patient lists so we don't need to
+7 ;check it here.
+8 SET PCLOG=DEFARR(31)
+9 IF PCLOG=""
QUIT
+10 SET OPER="!&~"
+11 ;Get the sex field, if PCLOG does not contain SEX set it to null.
+12 SET SEX=$SELECT(PCLOG["SEX":$PIECE(DEFARR(0),U,9),1:"")
+13 ;If PCLOG contains age build the corresponding date of birth range(s).
+14 IF PCLOG["AGE"
DO DOBR(.DEFARR,.NDR,.DOBS,.DOBE)
+15 ;Replace &' with ~ so the stack will be built properly.
+16 SET PCLOG=$$STRREP^PXRMUTIL(PCLOG,"&'","~")
+17 DO POSTFIX^PXRMSTAC(PCLOG,OPER,.PFSTACK)
+18 ;Process the logic.
+19 DO CFSAA(.PFSTACK)
+20 SET (IND,ERROR,LSP,LSTACK(0),NOT)=0
+21 FOR
IF (IND'<PFSTACK(0))!(ERROR)
QUIT
Begin DoDot:1
+22 SET IND=IND+1
SET ELE=PFSTACK(IND)
+23 IF ELE["'"
SET NOT=1
+24 SET TYPE=$SELECT(ELE="'":"NOT",ELE["AGE":"A",ELE["FI":"FI",ELE["FF":"FF",ELE="SAA":"SAA",ELE["SEX":"S",OPER[ELE:"OP",1:"")
+25 ;
+26 IF TYPE="A"
Begin DoDot:2
+27 SET LNAME="LIST"_IND
+28 DO LSA("",NDR,.DOBS,.DOBE,LNAME)
+29 DO PUSH^PXRMSTAC(.LSTACK,LNAME)
+30 DO AGEFI(.DEFARR,LNAME,SEX,"")
End DoDot:2
QUIT
+31 ;
+32 IF TYPE="FI"
Begin DoDot:2
+33 SET IND=IND+1
SET FNUM=PFSTACK(IND)
+34 IF +FNUM'=FNUM
SET ERROR=1
SET ERRSTR="Error - having a finding not followed by a number"
QUIT
+35 SET LNAME="LIST"_IND
+36 DO EVALPL^PXRMEVFI(.DEFARR,FNUM,LNAME)
+37 DO PUSH^PXRMSTAC(.LSTACK,LNAME)
End DoDot:2
QUIT
+38 ;
+39 IF TYPE="FF"
Begin DoDot:2
+40 SET IND=IND+1
SET FNUM=PFSTACK(IND)
+41 IF +FNUM'=FNUM
SET ERROR=1
SET ERRSTR="Error - having a function finding not followed by a number"
+42 SET LNAME="LIST"_IND
+43 DO EVALPL^PXRMFF(.DEFARR,"FF"_FNUM,LNAME)
+44 DO PUSH^PXRMSTAC(.LSTACK,LNAME)
End DoDot:2
QUIT
+45 ;
+46 IF TYPE="NOT"
SET NOT=1
QUIT
+47 ;
+48 IF TYPE="OP"
Begin DoDot:2
+49 SET LIST2=$$POP^PXRMSTAC(.LSTACK)
+50 SET LIST1=$$POP^PXRMSTAC(.LSTACK)
+51 IF NOT
SET ELE=ELE_"'"
SET NOT=0
+52 DO LOGOP(LIST1,LIST2,ELE)
+53 DO PUSH^PXRMSTAC(.LSTACK,LIST1)
+54 KILL ^TMP($JOB,LIST2)
End DoDot:2
QUIT
+55 ;
+56 IF TYPE="S"
Begin DoDot:2
+57 SET LNAME="LIST"_IND
+58 DO LSEX(SEX,LNAME,.LSTACK)
+59 DO PUSH^PXRMSTAC(.LSTACK,LNAME)
End DoDot:2
QUIT
+60 ;
+61 IF TYPE="SAA"
Begin DoDot:2
+62 SET LNAME="LIST"_IND
+63 DO LSA(SEX,NDR,.DOBS,.DOBE,LNAME)
+64 DO PUSH^PXRMSTAC(.LSTACK,LNAME)
+65 DO AGEFI(.DEFARR,LNAME,SEX,"")
End DoDot:2
QUIT
+66 ;
End DoDot:1
+67 SET LIST1=$$POP^PXRMSTAC(.LSTACK)
+68 ;If AGE is not in the cohort logic look for any findings that set the
+69 ;frequency to 0Y and therefore remove the patient from the cohort.
+70 IF PCLOG'["AGE"
DO AGEFI(.DEFARR,LIST1,"","0Y")
+71 ;
+72 IF $GET(DFNONLY)
Begin DoDot:1
+73 SET DFN=0
+74 FOR
SET DFN=$ORDER(^TMP($JOB,LIST1,1,DFN))
IF DFN=""
QUIT
Begin DoDot:2
+75 SET ^TMP($JOB,PLIST,DFN)=""
End DoDot:2
End DoDot:1
+76 IF '$TEST
MERGE ^TMP($JOB,PLIST)=^TMP($JOB,LIST1)
+77 KILL ^TMP($JOB,LIST1)
+78 QUIT
+79 ;
+80 ;==================================================
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.
+2 NEW DEL,DFN,DOB,DOBE,DOBS,FILIST,FINUM,FREQ,IND,JND,LOGOP
+3 NEW MINAGE,MAXAGE,NUMAFI,PSEX,RANK,RANKARR,RF,TEMP,TGLIST
+4 SET NUMAFI=$PIECE(DEFARR(40),U,1)
+5 IF NUMAFI=0
QUIT
+6 SET FILIST=$PIECE(DEFARR(40),U,2)
+7 FOR IND=1:1:NUMAFI
Begin DoDot:1
+8 SET FINUM=$PIECE(FILIST,";",IND)
+9 SET TEMP=$SELECT(FINUM["FF":DEFARR(25,FINUM,0),1:DEFARR(20,FINUM,0))
+10 SET RANK=+$PIECE(TEMP,U,5)
+11 IF RANK=0
SET RANK=9999
+12 SET FREQ=$$FRQINDAY^PXRMDATE($PIECE(TEMP,U,4))
+13 ;If there is no frequency with this rank ignore it.
+14 IF FREQ]""
SET RANKARR(RANK,FREQ,FINUM)=""
End DoDot:1
+15 SET IND=0
SET RANK=""
+16 FOR
SET RANK=$ORDER(RANKARR(RANK))
IF RANK=""
QUIT
Begin DoDot:1
+17 SET FREQ=""
+18 FOR
SET FREQ=$ORDER(RANKARR(RANK,FREQ))
IF FREQ=""
QUIT
Begin DoDot:2
+19 SET FINUM=0
+20 FOR
SET FINUM=$ORDER(RANKARR(RANK,FREQ,FINUM))
IF FINUM=""
QUIT
Begin DoDot:3
+21 SET IND=IND+1
SET RF(IND)=FINUM
End DoDot:3
End DoDot:2
End DoDot:1
+22 IF IND'=NUMAFI
WRITE !,"Error in AGEFI^PXRMPLST - Ranking failed!"
+23 ;Build a list for each age finding.
+24 FOR IND=1:1:NUMAFI
Begin DoDot:1
+25 SET FINUM=RF(IND)
+26 SET TGLIST="AGEFI"_FINUM
+27 SET TEMP=$SELECT(FINUM["FF":DEFARR(25,FINUM,0),1:DEFARR(20,FINUM,0))
+28 SET FREQ=$PIECE(TEMP,U,4)
+29 IF ONLYFREQ="0Y"
IF FREQ'="0Y"
SET LOGOP(IND)="~"
QUIT
+30 SET LOGOP(IND)=$SELECT(FREQ="0Y":"~",FREQ="":"~",1:"!")
+31 SET MINAGE=$PIECE(TEMP,U,2)
+32 SET MAXAGE=$PIECE(TEMP,U,3)
+33 SET DOBE=$SELECT(MINAGE="":$$NOW^PXRMDATE,1:$$GETDOB(MINAGE,"MIN"))
+34 SET DOBS=$SELECT(MAXAGE="":0,1:$$GETDOB(MAXAGE,"MAX"))
+35 KILL ^TMP($JOB,TGLIST)
+36 IF FINUM=+FINUM
DO EVALPL^PXRMEVFI(.DEFARR,FINUM,TGLIST)
+37 IF FINUM["FF"
DO EVALPL^PXRMFF(.DEFARR,FINUM,TGLIST)
+38 ;Filter TGLIST based on the age range.
+39 SET DFN=$SELECT(FREQ="0Y":$ORDER(^TMP($JOB,TGLIST,1,""),-1),1:0)
+40 FOR
SET DFN=$ORDER(^TMP($JOB,TGLIST,1,DFN))
IF DFN=""
QUIT
Begin DoDot:2
+41 SET DEL=0
+42 ;Reference to ^DPT DBIA #10035
+43 SET PSEX=$PIECE(^DPT(DFN,0),U,2)
SET DOB=$PIECE(^DPT(DFN,0),U,3)
+44 IF SEX'=""
IF PSEX'=SEX
SET DEL=1
+45 IF (DOB<DOBS)!(DOB>DOBE)
SET DEL=1
+46 IF DEL
KILL ^TMP($JOB,TGLIST,0,DFN),^TMP($JOB,TGLIST,1,DFN)
End DoDot:2
End DoDot:1
+47 ;Remove patients on a list with a higher rank from all lists with
+48 ;a lower rank.
+49 FOR IND=1:1:NUMAFI
Begin DoDot:1
+50 FOR JND=IND+1:1:NUMAFI
DO LOGOP("AGEFI"_RF(JND),"AGEFI"_RF(IND),"~")
End DoDot:1
+51 FOR IND=1:1:NUMAFI
Begin DoDot:1
+52 DO LOGOP(LNAME,"AGEFI"_RF(IND),LOGOP(IND))
+53 KILL ^TMP($JOB,"AGEFI"_RF(IND))
End DoDot:1
+54 QUIT
+55 ;
+56 ;==================================================
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"
+2 ;finding SAA.
+3 NEW EL1,EL2,EL3,SAA
+4 SET SAA=0
+5 SET EL1=$GET(STACK(1))
SET EL2=$GET(STACK(2))
SET EL3=$GET(STACK(3))
+6 IF EL1="SEX"
IF EL2="AGE"
IF EL3="&"
SET SAA=1
+7 IF EL1="AGE"
IF EL2="SEX"
IF EL3="&"
SET SAA=1
+8 IF 'SAA
QUIT
+9 ;Create a new pseudo-element for SEX&AGE.
+10 SET EL1=$$POP^PXRMSTAC(.STACK)
+11 SET EL1=$$POP^PXRMSTAC(.STACK)
+12 SET EL1=$$POP^PXRMSTAC(.STACK)
+13 DO PUSH^PXRMSTAC(.STACK,"SAA")
+14 QUIT
+15 ;
+16 ;==================================================
DOBR(DEFARR,NDR,DOBS,DOBE) ;Build the date of birth range.
+1 NEW IND,FREQ,MINAGE,MAXAGE,TEMP
+2 SET (IND,NDR)=0
+3 FOR
SET IND=+$ORDER(DEFARR(7,IND))
IF IND=0
QUIT
Begin DoDot:1
+4 SET TEMP=DEFARR(7,IND,0)
+5 SET FREQ=$PIECE(TEMP,U,1)
+6 IF (FREQ="0Y")!(FREQ="")
QUIT
+7 SET MINAGE=$PIECE(TEMP,U,2)
+8 SET MAXAGE=$PIECE(TEMP,U,3)
+9 SET NDR=NDR+1
+10 SET DOBE(NDR)=$SELECT(MINAGE="":$$NOW^PXRMDATE,1:$$GETDOB(MINAGE,"MIN"))
+11 SET DOBS(NDR)=$SELECT(MAXAGE="":0,1:$$GETDOB(MAXAGE,"MAX"))
End DoDot:1
+12 QUIT
+13 ;
+14 ;==================================================
GENTERM(FINDING,FINUM,TERMARR) ;Given a reminder finding generate a term
+1 ;for patient list evaluation.
+2 NEW IEN,IND,TEMP,TYPE
+3 KILL TERMARR
+4 SET TEMP=$PIECE(FINDING,U,1)
+5 SET IEN=$PIECE(TEMP,";",1)
+6 SET TYPE=$PIECE(TEMP,";",2)
+7 ;If the finding is a term just load the term.
+8 IF TYPE="PXRMD(811.5,"
DO TERM^PXRMLDR(IEN,.TERMARR)
QUIT
+9 SET TERMARR(0)="GENERATED"
+10 SET TERMARR("IEN")=0
+11 MERGE TERMARR(20,1)=DEFARR(20,FINUM)
+12 SET TERMARR("E",TYPE,IEN,1)=""
+13 QUIT
+14 ;
+15 ;==================================================
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
+2 ;that age. If TYPE is MAX find the last day that will make them
+3 ;that age, i.e., the next day is their birthday.
+4 NEW DATE,DOB
+5 SET DATE=$$NOW^PXRMDATE
+6 IF TYPE="MIN"
SET DOB=DATE-(10000*AGE)
+7 IF TYPE="MAX"
SET DOB=DATE-(10000*(AGE+1))
SET DOB=$$FMADD^XLFDT(DOB,1)
+8 QUIT DOB
+9 ;
+10 ;==================================================
LOGOP(LIST1,LIST2,LOGOP) ;Given LIST1 and LIST2 apply the logical
+1 ;operator LOGOP to generate a new list and return it in LIST1
+2 NEW DFN1,DFN2
+3 IF LOGOP="&"
Begin DoDot:1
+4 SET DFN1=""
+5 FOR
SET DFN1=$ORDER(^TMP($JOB,LIST1,1,DFN1))
IF DFN1=""
QUIT
Begin DoDot:2
+6 IF $DATA(^TMP($JOB,LIST2,1,DFN1))
MERGE ^TMP($JOB,LIST1,1,DFN1)=^TMP($JOB,LIST2,1,DFN1)
QUIT
+7 KILL ^TMP($JOB,LIST1,1,DFN1)
End DoDot:2
End DoDot:1
QUIT
+8 ;
+9 ;"~" represents "&'".
+10 IF LOGOP="~"
Begin DoDot:1
+11 SET DFN1=""
+12 FOR
SET DFN1=$ORDER(^TMP($JOB,LIST1,1,DFN1))
IF DFN1=""
QUIT
Begin DoDot:2
+13 IF $DATA(^TMP($JOB,LIST2,1,DFN1))
KILL ^TMP($JOB,LIST1,1,DFN1)
End DoDot:2
End DoDot:1
QUIT
+14 ;
+15 IF LOGOP="!"
Begin DoDot:1
+16 SET DFN2=""
+17 FOR
SET DFN2=$ORDER(^TMP($JOB,LIST2,1,DFN2))
IF DFN2=""
QUIT
Begin DoDot:2
+18 MERGE ^TMP($JOB,LIST1,1,DFN2)=^TMP($JOB,LIST2,1,DFN2)
End DoDot:2
End DoDot:1
+19 QUIT
+20 ;
+21 ;==================================================
LSA(SEX,NDR,DOBS,DOBE,LNAME) ;Build a list from a SEX & AGE finding.
+1 ;Reference to ^DPT DBIA #10035
+2 NEW DFN,DS,IND,SEXOK
+3 FOR IND=1:1:NDR
Begin DoDot:1
+4 SET DS=DOBS(IND)-.000001
+5 FOR
SET DS=$ORDER(^DPT("ADOB",DS))
IF (DS>DOBE(IND))!(DS="")
QUIT
Begin DoDot:2
+6 SET DFN=""
+7 FOR
SET DFN=$ORDER(^DPT("ADOB",DS,DFN))
IF DFN=""
QUIT
Begin DoDot:3
+8 SET SEXOK=$SELECT(SEX="":1,$DATA(^DPT("ASX",SEX,DFN)):1,1:0)
+9 IF SEXOK
SET ^TMP($JOB,LNAME,1,DFN,1,"SAA")=""
End DoDot:3
End DoDot:2
End DoDot:1
+10 QUIT
+11 ;
+12 ;==================================================
LSEX(SEX,LNAME,LSTACK) ;Build a list from a SEX finding.
+1 ;Reference to ^DPT DBIA #10035
+2 NEW ELIST
+3 ;Start with the existing list to build a list based on sex.
+4 SET ELIST=$$POP^PXRMSTAC(.LSTACK)
+5 DO PUSH^PXRMSTAC(.LSTACK,ELIST)
+6 SET DFN=0
+7 FOR
SET DFN=$ORDER(^TMP($JOB,ELIST,1,DFN))
IF DFN=""
QUIT
Begin DoDot:1
+8 IF $DATA(^DPT("ASX",SEX,DFN))
SET ^TMP($JOB,LNAME,1,DFN,SEX,1)=""
End DoDot:1
+9 QUIT
+10 ;
