- PXRMPLST ;SLC/PKR - Build a patient list from a reminder definition. ;08/17/2017
- ;;2.0;CLINICAL REMINDERS;**4,6,18,42**;Feb 04, 2005;Build 245
- ;
- ;Input : DEFARR - Reminder definition
- ; 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
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMPLST 8909 printed Feb 18, 2025@23:14:57 Page 2
- 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
- +2 ;
- +3 ;Input : DEFARR - Reminder definition
- +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 ;