Changeset 623 for WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMPLST.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMPLST.m
r613 r623 1 PXRMPLST ; SLC/PKR - Build a patient list from a reminder definition. ;01/24/2007 2 ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 3 ; 4 ;Input : RIEN - Reminder IEN 5 ; PLIST - List returned in ^TMP($J,PLIST,DFN) 6 ; DFNONLY - If true list contains only DFN information 7 ; PXRMDATE - Evaluation date 8 ;=================================================== 9 BLDPLST(DEFARR,PLIST,DFNONLY) ; 10 N DFN,DOBE,DOBS,ELE,ERROR,ERRSTR,IND,FNUM 11 N LIST1,LIST2,LNAME,LSP,LSTACK 12 N NDR,NOT,OPER,PCLOG,PFSTACK,SEX,TYPE 13 ; 14 ;Get the cohort logic string. This has passed a validation before 15 ;it can be selected for building patient lists so we don't need to 16 ;check it here. 17 S PCLOG=DEFARR(31) 18 I PCLOG="" Q 19 S OPER="!&~" 20 ;Get the sex field, if PCLOG does not contain SEX set it to null. 21 S SEX=$S(PCLOG["SEX":$P(DEFARR(0),U,9),1:"") 22 ;If PCLOG contains age build the corresponding date of birth range(s). 23 I PCLOG["AGE" D DOBR(.DEFARR,.NDR,.DOBS,.DOBE) 24 ;Replace &' with ~ so the stack will be built properly. 25 S PCLOG=$$STRREP^PXRMUTIL(PCLOG,"&'","~") 26 D POSTFIX^PXRMSTAC(PCLOG,OPER,.PFSTACK) 27 ;Process the logic. 28 D CFSAA(.PFSTACK) 29 S (IND,ERROR,LSP,LSTACK(0),NOT)=0 30 F Q:(IND'<PFSTACK(0))!(ERROR) D 31 . S IND=IND+1,ELE=PFSTACK(IND) 32 . I ELE["'" S NOT=1 33 . S TYPE=$S(ELE="'":"NOT",ELE["AGE":"A",ELE["FI":"FI",ELE["FF":"FF",ELE="SAA":"SAA",ELE["SEX":"S",OPER[ELE:"OP",1:"") 34 .; 35 . I TYPE="A" D Q 36 .. S LNAME="LIST"_IND 37 .. D LSA("",NDR,.DOBS,.DOBE,LNAME) 38 .. D PUSH^PXRMSTAC(.LSTACK,LNAME) 39 .. D AGEFI(.DEFARR,LNAME,SEX,"") 40 .; 41 . I TYPE="FI" D Q 42 .. S IND=IND+1,FNUM=PFSTACK(IND) 43 .. I +FNUM'=FNUM S ERROR=1,ERRSTR="Error - having a finding not followed by a number" Q 44 .. S LNAME="LIST"_IND 45 .. D EVALPL^PXRMEVFI(.DEFARR,FNUM,LNAME) 46 .. D PUSH^PXRMSTAC(.LSTACK,LNAME) 47 .; 48 . I TYPE="FF" D Q 49 .. S IND=IND+1,FNUM=PFSTACK(IND) 50 .. I +FNUM'=FNUM S ERROR=1,ERRSTR="Error - having a function finding not followed by a number" 51 .. S LNAME="LIST"_IND 52 .. D EVALPL^PXRMFF(.DEFARR,"FF"_FNUM,LNAME) 53 .. D PUSH^PXRMSTAC(.LSTACK,LNAME) 54 .; 55 . I TYPE="NOT" S NOT=1 Q 56 .; 57 . I TYPE="OP" D Q 58 .. S LIST2=$$POP^PXRMSTAC(.LSTACK) 59 .. S LIST1=$$POP^PXRMSTAC(.LSTACK) 60 .. I NOT S ELE=ELE_"'",NOT=0 61 .. D LOGOP(LIST1,LIST2,ELE) 62 .. D PUSH^PXRMSTAC(.LSTACK,LIST1) 63 .. K ^TMP($J,LIST2) 64 .; 65 . I TYPE="S" D Q 66 .. S LNAME="LIST"_IND 67 .. D LSEX(SEX,LNAME,.LSTACK) 68 .. D PUSH^PXRMSTAC(.LSTACK,LNAME) 69 .; 70 . I TYPE="SAA" D Q 71 .. S LNAME="LIST"_IND 72 .. D LSA(SEX,NDR,.DOBS,.DOBE,LNAME) 73 .. D PUSH^PXRMSTAC(.LSTACK,LNAME) 74 .. D AGEFI(.DEFARR,LNAME,SEX,"") 75 .; 76 S LIST1=$$POP^PXRMSTAC(.LSTACK) 77 ;If AGE is not in the cohort logic look for any findings that set the 78 ;frequency to 0Y and therefore remove the patient from the cohort. 79 I PCLOG'["AGE" D AGEFI(.DEFARR,LIST1,"","0Y") 80 ; 81 I $G(DFNONLY) D 82 . S DFN=0 83 . F S DFN=$O(^TMP($J,LIST1,1,DFN)) Q:DFN="" D 84 .. S ^TMP($J,PLIST,DFN)="" 85 E M ^TMP($J,PLIST)=^TMP($J,LIST1) 86 K ^TMP($J,LIST1) 87 Q 88 ; 89 ;================================================== 90 AGEFI(DEFARR,LNAME,SEX,ONLYFREQ) ;Check for patients that need to be 91 ;added or removed because of a finding that changes the age range. 92 N DEL,DFN,DOB,DOBE,DOBS,FILIST,FINUM,FREQ,IND,JND,LOGOP 93 N MINAGE,MAXAGE,NUMAFI,PSEX,RANK,RANKARR,RF,TEMP,TGLIST 94 S NUMAFI=$P(DEFARR(40),U,1) 95 I NUMAFI=0 Q 96 S FILIST=$P(DEFARR(40),U,2) 97 F IND=1:1:NUMAFI D 98 . S FINUM=$P(FILIST,";",IND) 99 . S TEMP=$S(FINUM["FF":DEFARR(25,FINUM,0),1:DEFARR(20,FINUM,0)) 100 . S RANK=+$P(TEMP,U,5) 101 . I RANK=0 S RANK=9999 102 . S FREQ=$$FRQINDAY^PXRMDATE($P(TEMP,U,4)) 103 .;If there is no frequency with this rank ignore it. 104 . I FREQ]"" S RANKARR(RANK,FREQ,FINUM)="" 105 S IND=0,RANK="" 106 F S RANK=$O(RANKARR(RANK)) Q:RANK="" D 107 . S FREQ="" 108 . F S FREQ=$O(RANKARR(RANK,FREQ)) Q:FREQ="" D 109 .. S FINUM=0 110 .. F S FINUM=$O(RANKARR(RANK,FREQ,FINUM)) Q:FINUM="" D 111 ... S IND=IND+1,RF(IND)=FINUM 112 I IND'=NUMAFI W !,"Error in AGEFI^PXRMPLST - Ranking failed!" 113 ;Build a list for each age finding. 114 F IND=1:1:NUMAFI D 115 . S FINUM=RF(IND) 116 . S TGLIST="AGEFI"_FINUM 117 . S TEMP=$S(FINUM["FF":DEFARR(25,FINUM,0),1:DEFARR(20,FINUM,0)) 118 . S FREQ=$P(TEMP,U,4) 119 . I ONLYFREQ="0Y",FREQ'="0Y" S LOGOP(IND)="~" Q 120 . S LOGOP(IND)=$S(FREQ="0Y":"~",FREQ="":"~",1:"!") 121 . S MINAGE=$P(TEMP,U,2) 122 . S MAXAGE=$P(TEMP,U,3) 123 . S DOBE=$S(MINAGE="":$$NOW^PXRMDATE,1:$$GETDOB(MINAGE,"MIN")) 124 . S DOBS=$S(MAXAGE="":0,1:$$GETDOB(MAXAGE,"MAX")) 125 . K ^TMP($J,TGLIST) 126 . I FINUM=+FINUM D EVALPL^PXRMEVFI(.DEFARR,FINUM,TGLIST) 127 . I FINUM["FF" D EVALPL^PXRMFF(.DEFARR,FINUM,TGLIST) 128 .;Filter TGLIST based on the age range. 129 . S DFN=$S(FREQ="0Y":$O(^TMP($J,TGLIST,1,""),-1),1:0) 130 . F S DFN=$O(^TMP($J,TGLIST,1,DFN)) Q:DFN="" D 131 .. S DEL=0 132 ..;Reference to ^DPT DBIA #10035 133 .. S PSEX=$P(^DPT(DFN,0),U,2),DOB=$P(^DPT(DFN,0),U,3) 134 .. I SEX'="",PSEX'=SEX S DEL=1 135 .. I (DOB<DOBS)!(DOB>DOBE) S DEL=1 136 .. I DEL K ^TMP($J,TGLIST,0,DFN),^TMP($J,TGLIST,1,DFN) 137 ;Remove patients on a list with a higher rank from all lists with 138 ;a lower rank. 139 F IND=1:1:NUMAFI D 140 . F JND=IND+1:1:NUMAFI D LOGOP("AGEFI"_RF(JND),"AGEFI"_RF(IND),"~") 141 F IND=1:1:NUMAFI D 142 . D LOGOP(LNAME,"AGEFI"_RF(IND),LOGOP(IND)) 143 . K ^TMP($J,"AGEFI"_RF(IND)) 144 Q 145 ; 146 ;================================================== 147 CFSAA(STACK) ;Check for the first three elements on the stack being 148 ;SEX, AGE, and &. If that is the case replace the with the "special" 149 ;finding SAA. 150 N EL1,EL2,EL3,SAA 151 S SAA=0 152 S EL1=$G(STACK(1)),EL2=$G(STACK(2)),EL3=$G(STACK(3)) 153 I EL1="SEX",EL2="AGE",EL3="&" S SAA=1 154 I EL1="AGE",EL2="SEX",EL3="&" S SAA=1 155 I 'SAA Q 156 ;Create a new pseudo-element for SEX&AGE. 157 S EL1=$$POP^PXRMSTAC(.STACK) 158 S EL1=$$POP^PXRMSTAC(.STACK) 159 S EL1=$$POP^PXRMSTAC(.STACK) 160 D PUSH^PXRMSTAC(.STACK,"SAA") 161 Q 162 ; 163 ;================================================== 164 DOBR(DEFARR,NDR,DOBS,DOBE) ;Build the date of birth range. 165 N IND,FREQ,MINAGE,MAXAGE,TEMP 166 S (IND,NDR)=0 167 F S IND=+$O(DEFARR(7,IND)) Q:IND=0 D 168 . S TEMP=DEFARR(7,IND,0) 169 . S FREQ=$P(TEMP,U,1) 170 . I (FREQ="0Y")!(FREQ="") Q 171 . S MINAGE=$P(TEMP,U,2) 172 . S MAXAGE=$P(TEMP,U,3) 173 . S NDR=NDR+1 174 . S DOBE(NDR)=$S(MINAGE="":$$NOW^PXRMDATE,1:$$GETDOB(MINAGE,"MIN")) 175 . S DOBS(NDR)=$S(MAXAGE="":0,1:$$GETDOB(MAXAGE,"MAX")) 176 Q 177 ; 178 ;================================================== 179 GENTERM(FINDING,FINUM,TERMARR) ;Given a reminder finding generate a term 180 ;for patient list evaluation. 181 N IEN,IND,TEMP,TYPE 182 S TEMP=$P(FINDING,U,1) 183 S IEN=$P(TEMP,";",1) 184 S TYPE=$P(TEMP,";",2) 185 ;If the finding is a term just load the term. 186 I TYPE="PXRMD(811.5," D TERM^PXRMLDR(IEN,.TERMARR) Q 187 S TERMARR(0)="GENERATED" 188 S TERMARR("IEN")=0 189 M TERMARR(20,1)=DEFARR(20,FINUM) 190 S TERMARR("E",TYPE,IEN,1)="" 191 Q 192 ; 193 ;================================================== 194 GETDOB(AGE,TYPE) ;Given an age in years return the corresponding date of 195 ;birth. If TYPE is MIN then find the date of birth that will make them 196 ;that age. If TYPE is MAX find the last day that will make them 197 ;that age, i.e., the next day is their birthday. 198 N DATE,DOB 199 S DATE=$$NOW^PXRMDATE 200 I TYPE="MIN" S DOB=DATE-(10000*AGE) 201 I TYPE="MAX" S DOB=DATE-(10000*(AGE+1)),DOB=$$FMADD^XLFDT(DOB,1) 202 Q DOB 203 ; 204 ;================================================== 205 LOGOP(LIST1,LIST2,LOGOP) ;Given LIST1 and LIST2 apply the logical 206 ;operator LOGOP to generate a new list and return it in LIST1 207 N DFN1,DFN2 208 I LOGOP="&" D Q 209 . S DFN1="" 210 . F S DFN1=$O(^TMP($J,LIST1,1,DFN1)) Q:DFN1="" D 211 .. I $D(^TMP($J,LIST2,1,DFN1)) M ^TMP($J,LIST1,1,DFN1)=^TMP($J,LIST2,1,DFN1) Q 212 .. K ^TMP($J,LIST1,1,DFN1) 213 ; 214 ;"~" represents "&'". 215 I LOGOP="~" D Q 216 . S DFN1="" 217 . F S DFN1=$O(^TMP($J,LIST1,1,DFN1)) Q:DFN1="" D 218 .. I $D(^TMP($J,LIST2,1,DFN1)) K ^TMP($J,LIST1,1,DFN1) 219 ; 220 I LOGOP="!" D 221 . S DFN2="" 222 . F S DFN2=$O(^TMP($J,LIST2,1,DFN2)) Q:DFN2="" D 223 .. M ^TMP($J,LIST1,1,DFN2)=^TMP($J,LIST2,1,DFN2) 224 Q 225 ; 226 ;================================================== 227 LSA(SEX,NDR,DOBS,DOBE,LNAME) ;Build a list from a SEX & AGE finding. 228 ;Reference to ^DPT DBIA #10035 229 N DFN,DS,IND,SEXOK 230 F IND=1:1:NDR D 231 . S DS=DOBS(IND)-.000001 232 . F S DS=$O(^DPT("ADOB",DS)) Q:(DS>DOBE(IND))!(DS="") D 233 .. S DFN="" 234 .. F S DFN=$O(^DPT("ADOB",DS,DFN)) Q:DFN="" D 235 ... S SEXOK=$S(SEX="":1,$D(^DPT("ASX",SEX,DFN)):1,1:0) 236 ... I SEXOK S ^TMP($J,LNAME,1,DFN,1,"SAA")="" 237 Q 238 ; 239 ;================================================== 240 LSEX(SEX,LNAME,LSTACK) ;Build a list from a SEX finding. 241 ;Reference to ^DPT DBIA #10035 242 N ELIST 243 ;Start with the existing list to build a list based on sex. 244 S ELIST=$$POP^PXRMSTAC(.LSTACK) 245 D PUSH^PXRMSTAC(.LSTACK,ELIST) 246 S DFN=0 247 F S DFN=$O(^TMP($J,ELIST,1,DFN)) Q:DFN="" D 248 . I $D(^DPT("ASX",SEX,DFN)) S ^TMP($J,LNAME,1,DFN,SEX,1)="" 249 Q 250 ; 1 PXRMPLST ; SLC/PKR - Build a patient list from a reminder definition. ;06/09/2006 2 ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21 3 ; 4 ;Input : RIEN - Reminder IEN 5 ; PLIST - List returned in ^TMP($J,PLIST,DFN) 6 ; DFNONLY - If true list contains only DFN information 7 ; PXRMDATE - Evaluation date 8 ;=================================================== 9 BLDPLST(RIEN,PLIST,DFNONLY,PXRMDATE) ; 10 N DEFARR,DFN,DOBE,DOBS,ELE,ERROR,ERRSTR,IND,FNUM 11 N LIST1,LIST2,LNAME,LSP,LSTACK 12 N NDR,NOT,OPER,PCLOG,PFSTACK,SEX,TYPE 13 ; 14 D DEF^PXRMLDR(RIEN,.DEFARR) 15 ;Get the cohort logic string. This has passed a validation before 16 ;it can be selected for building patient lists so we don't need to 17 ;check it here. 18 S PCLOG=DEFARR(31) 19 I PCLOG="" Q 20 S OPER="!&~" 21 ;Get the sex field, if PCLOG does not contain SEX set it to null. 22 S SEX=$S(PCLOG["SEX":$P(DEFARR(0),U,9),1:"") 23 ;If PCLOG contains age build the corresponding date of birth range(s). 24 I PCLOG["AGE" D DOBR(.DEFARR,.NDR,.DOBS,.DOBE) 25 ;Replace &' with ~ so the stack will be built properly. 26 S PCLOG=$$STRREP^PXRMUTIL(PCLOG,"&'","~") 27 D POSTFIX^PXRMSTAC(PCLOG,OPER,.PFSTACK) 28 ;Process the logic. 29 D CFSAA(.PFSTACK) 30 S (IND,ERROR,LSP,LSTACK(0),NOT)=0 31 F Q:(IND'<PFSTACK(0))!(ERROR) D 32 . S IND=IND+1,ELE=PFSTACK(IND) 33 . I ELE["'" S NOT=1 34 . S TYPE=$S(ELE="'":"NOT",ELE["AGE":"A",ELE["FI":"FI",ELE["FF":"FF",ELE="SAA":"SAA",ELE["SEX":"S",OPER[ELE:"OP",1:"") 35 .; 36 . I TYPE="A" D Q 37 .. S LNAME="LIST"_IND 38 .. D LSA("",NDR,.DOBS,.DOBE,LNAME) 39 .. D PUSH^PXRMSTAC(.LSTACK,LNAME) 40 .. D AGEFI(.DEFARR,LNAME,SEX,"") 41 .; 42 . I TYPE="FI" D Q 43 .. S IND=IND+1,FNUM=PFSTACK(IND) 44 .. I +FNUM'=FNUM S ERROR=1,ERRSTR="Error - having a finding not followed by a number" Q 45 .. S LNAME="LIST"_IND 46 .. D EVALPL^PXRMEVFI(.DEFARR,FNUM,LNAME) 47 .. D PUSH^PXRMSTAC(.LSTACK,LNAME) 48 .; 49 . I TYPE="FF" D Q 50 .. S IND=IND+1,FNUM=PFSTACK(IND) 51 .. I +FNUM'=FNUM S ERROR=1,ERRSTR="Error - having a function finding not followed by a number" 52 .. S LNAME="LIST"_IND 53 .. D EVALPL^PXRMFF(.DEFARR,"FF"_FNUM,LNAME) 54 .. D PUSH^PXRMSTAC(.LSTACK,LNAME) 55 .; 56 . I TYPE="NOT" S NOT=1 Q 57 .; 58 . I TYPE="OP" D Q 59 .. S LIST2=$$POP^PXRMSTAC(.LSTACK) 60 .. S LIST1=$$POP^PXRMSTAC(.LSTACK) 61 .. I NOT S ELE=ELE_"'",NOT=0 62 .. D LOGOP(LIST1,LIST2,ELE) 63 .. D PUSH^PXRMSTAC(.LSTACK,LIST1) 64 .. K ^TMP($J,LIST2) 65 .; 66 . I TYPE="S" D Q 67 .. S LNAME="LIST"_IND 68 .. D LSEX(SEX,LNAME,.LSTACK) 69 .. D PUSH^PXRMSTAC(.LSTACK,LNAME) 70 .; 71 . I TYPE="SAA" D Q 72 .. S LNAME="LIST"_IND 73 .. D LSA(SEX,NDR,.DOBS,.DOBE,LNAME) 74 .. D PUSH^PXRMSTAC(.LSTACK,LNAME) 75 .. D AGEFI(.DEFARR,LNAME,SEX,"") 76 .; 77 S LIST1=$$POP^PXRMSTAC(.LSTACK) 78 ;If AGE is not in the cohort logic look for any findings that set the 79 ;frequency to 0Y and therefore remove the patient from the cohort. 80 I PCLOG'["AGE" D AGEFI(.DEFARR,LIST1,"","0Y") 81 ; 82 I $G(DFNONLY) D 83 . S DFN=0 84 . F S DFN=$O(^TMP($J,LIST1,1,DFN)) Q:DFN="" D 85 .. S ^TMP($J,PLIST,DFN)="" 86 E M ^TMP($J,PLIST)=^TMP($J,LIST1) 87 K ^TMP($J,LIST1) 88 Q 89 ; 90 ;================================================== 91 AGEFI(DEFARR,LNAME,SEX,ONLYFREQ) ;Check for patients that need to be 92 ;added or removed because of a finding that changes the age range. 93 N DEL,DFN,DOB,DOBE,DOBS,FILIST,FINUM,FREQ,IND,JND,LOGOP 94 N MINAGE,MAXAGE,NUMAFI,PSEX,RANK,RANKARR,RF,TEMP,TGLIST 95 S NUMAFI=$P(DEFARR(40),U,1) 96 I NUMAFI=0 Q 97 S FILIST=$P(DEFARR(40),U,2) 98 F IND=1:1:NUMAFI D 99 . S FINUM=$P(FILIST,";",IND) 100 . S TEMP=$S(FINUM["FF":DEFARR(25,FINUM,0),1:DEFARR(20,FINUM,0)) 101 . S RANK=+$P(TEMP,U,5) 102 . I RANK=0 S RANK=9999 103 . S FREQ=$$FRQINDAY^PXRMDATE($P(TEMP,U,4)) 104 .;If there is no frequency with this rank ignore it. 105 . I FREQ]"" S RANKARR(RANK,FREQ,FINUM)="" 106 S IND=0,RANK="" 107 F S RANK=$O(RANKARR(RANK)) Q:RANK="" D 108 . S FREQ="" 109 . F S FREQ=$O(RANKARR(RANK,FREQ)) Q:FREQ="" D 110 .. S FINUM=0 111 .. F S FINUM=$O(RANKARR(RANK,FREQ,FINUM)) Q:FINUM="" D 112 ... S IND=IND+1,RF(IND)=FINUM 113 I IND'=NUMAFI W !,"Error in AGEFI^PXRMPLST - Ranking failed!" 114 ;Build a list for each age finding. 115 F IND=1:1:NUMAFI D 116 . S FINUM=RF(IND) 117 . S TGLIST="AGEFI"_FINUM 118 . S TEMP=$S(FINUM["FF":DEFARR(25,FINUM,0),1:DEFARR(20,FINUM,0)) 119 . S FREQ=$P(TEMP,U,4) 120 . I ONLYFREQ="0Y",FREQ'="0Y" S LOGOP(IND)="~" Q 121 . S LOGOP(IND)=$S(FREQ="0Y":"~",FREQ="":"~",1:"!") 122 . S MINAGE=$P(TEMP,U,2) 123 . S MAXAGE=$P(TEMP,U,3) 124 . S DOBE=$S(MINAGE="":$$NOW^PXRMDATE,1:$$GETDOB(MINAGE,"MIN")) 125 . S DOBS=$S(MAXAGE="":0,1:$$GETDOB(MAXAGE,"MAX")) 126 . K ^TMP($J,TGLIST) 127 . I FINUM=+FINUM D EVALPL^PXRMEVFI(.DEFARR,FINUM,TGLIST) 128 . I FINUM["FF" D EVALPL^PXRMFF(.DEFARR,FINUM,TGLIST) 129 .;Filter TGLIST based on the age range. 130 . S DFN=$S(FREQ="0Y":$O(^TMP($J,TGLIST,1,""),-1),1:0) 131 . F S DFN=$O(^TMP($J,TGLIST,1,DFN)) Q:DFN="" D 132 .. S DEL=0 133 ..;Reference to ^DPT DBIA #10035 134 .. S PSEX=$P(^DPT(DFN,0),U,2),DOB=$P(^DPT(DFN,0),U,3) 135 .. I SEX'="",PSEX'=SEX S DEL=1 136 .. I (DOB<DOBS)!(DOB>DOBE) S DEL=1 137 .. I DEL K ^TMP($J,TGLIST,0,DFN),^TMP($J,TGLIST,1,DFN) 138 ;Remove patients on a list with a higher rank from all lists with 139 ;a lower rank. 140 F IND=1:1:NUMAFI D 141 . F JND=IND+1:1:NUMAFI D LOGOP("AGEFI"_RF(JND),"AGEFI"_RF(IND),"~") 142 F IND=1:1:NUMAFI D 143 . D LOGOP(LNAME,"AGEFI"_RF(IND),LOGOP(IND)) 144 . K ^TMP($J,"AGEFI"_RF(IND)) 145 Q 146 ; 147 ;================================================== 148 CFSAA(STACK) ;Check for the first three elements on the stack being 149 ;SEX, AGE, and &. If that is the case replace the with the "special" 150 ;finding SAA. 151 N EL1,EL2,EL3,SAA 152 S SAA=0 153 S EL1=$G(STACK(1)),EL2=$G(STACK(2)),EL3=$G(STACK(3)) 154 I EL1="SEX",EL2="AGE",EL3="&" S SAA=1 155 I EL1="AGE",EL2="SEX",EL3="&" S SAA=1 156 I 'SAA Q 157 ;Create a new pseudo-element for SEX&AGE. 158 S EL1=$$POP^PXRMSTAC(.STACK) 159 S EL1=$$POP^PXRMSTAC(.STACK) 160 S EL1=$$POP^PXRMSTAC(.STACK) 161 D PUSH^PXRMSTAC(.STACK,"SAA") 162 Q 163 ; 164 ;================================================== 165 DOBR(DEFARR,NDR,DOBS,DOBE) ;Build the date of birth range. 166 N IND,FREQ,MINAGE,MAXAGE,TEMP 167 S (IND,NDR)=0 168 F S IND=+$O(DEFARR(7,IND)) Q:IND=0 D 169 . S TEMP=DEFARR(7,IND,0) 170 . S FREQ=$P(TEMP,U,1) 171 . I (FREQ="0Y")!(FREQ="") Q 172 . S MINAGE=$P(TEMP,U,2) 173 . S MAXAGE=$P(TEMP,U,3) 174 . S NDR=NDR+1 175 . S DOBE(NDR)=$S(MINAGE="":$$NOW^PXRMDATE,1:$$GETDOB(MINAGE,"MIN")) 176 . S DOBS(NDR)=$S(MAXAGE="":0,1:$$GETDOB(MAXAGE,"MAX")) 177 Q 178 ; 179 ;================================================== 180 GENTERM(FINDING,FINUM,TERMARR) ;Given a reminder finding generate a term 181 ;for patient list evaluation. 182 N IEN,IND,TEMP,TYPE 183 S TEMP=$P(FINDING,U,1) 184 S IEN=$P(TEMP,";",1) 185 S TYPE=$P(TEMP,";",2) 186 ;If the finding is a term just load the term. 187 I TYPE="PXRMD(811.5," D TERM^PXRMLDR(IEN,.TERMARR) Q 188 S TERMARR(0)="GENERATED" 189 S TERMARR("IEN")=0 190 M TERMARR(20,1)=DEFARR(20,FINUM) 191 S TERMARR("E",TYPE,IEN,1)="" 192 Q 193 ; 194 ;================================================== 195 GETDOB(AGE,TYPE) ;Given an age in years return the corresponding date of 196 ;birth. If TYPE is MIN then find the date of birth that will make them 197 ;that age. If TYPE is MAX find the last day that will make them 198 ;that age, i.e., the next day is their birthday. 199 N DATE,DOB 200 S DATE=$$NOW^PXRMDATE 201 I TYPE="MIN" S DOB=DATE-(10000*AGE) 202 I TYPE="MAX" S DOB=DATE-(10000*(AGE+1)),DOB=$$FMADD^XLFDT(DOB,1) 203 Q DOB 204 ; 205 ;================================================== 206 LOGOP(LIST1,LIST2,LOGOP) ;Given LIST1 and LIST2 apply the logical 207 ;operator LOGOP to generate a new list and return it in LIST1 208 N DFN1,DFN2 209 I LOGOP="&" D Q 210 . S DFN1="" 211 . F S DFN1=$O(^TMP($J,LIST1,1,DFN1)) Q:DFN1="" D 212 .. I $D(^TMP($J,LIST2,1,DFN1)) M ^TMP($J,LIST1,1,DFN1)=^TMP($J,LIST2,1,DFN1) Q 213 .. K ^TMP($J,LIST1,1,DFN1) 214 ; 215 ;"~" represents "&'". 216 I LOGOP="~" D Q 217 . S DFN1="" 218 . F S DFN1=$O(^TMP($J,LIST1,1,DFN1)) Q:DFN1="" D 219 .. I $D(^TMP($J,LIST2,1,DFN1)) K ^TMP($J,LIST1,1,DFN1) 220 ; 221 I LOGOP="!" D 222 . S DFN2="" 223 . F S DFN2=$O(^TMP($J,LIST2,1,DFN2)) Q:DFN2="" D 224 .. M ^TMP($J,LIST1,1,DFN2)=^TMP($J,LIST2,1,DFN2) 225 Q 226 ; 227 ;================================================== 228 LSA(SEX,NDR,DOBS,DOBE,LNAME) ;Build a list from a SEX & AGE finding. 229 ;Reference to ^DPT DBIA #10035 230 N DFN,DS,IND,SEXOK 231 F IND=1:1:NDR D 232 . S DS=DOBS(IND)-.1 233 . F S DS=$O(^DPT("ADOB",DS)) Q:(DS>DOBE(IND))!(DS="") D 234 .. S DFN="" 235 .. F S DFN=$O(^DPT("ADOB",DS,DFN)) Q:DFN="" D 236 ... S SEXOK=$S(SEX="":1,$D(^DPT("ASX",SEX,DFN)):1,1:0) 237 ... I SEXOK S ^TMP($J,LNAME,1,DFN,1,"SAA")="" 238 Q 239 ; 240 ;================================================== 241 LSEX(SEX,LNAME,LSTACK) ;Build a list from a SEX finding. 242 ;Reference to ^DPT DBIA #10035 243 N ELIST 244 ;Start with the existing list to build a list based on sex. 245 S ELIST=$$POP^PXRMSTAC(.LSTACK) 246 D PUSH^PXRMSTAC(.LSTACK,ELIST) 247 S DFN=0 248 F S DFN=$O(^TMP($J,ELIST,1,DFN)) Q:DFN="" D 249 . I $D(^DPT("ASX",SEX,DFN)) S ^TMP($J,LNAME,1,DFN,SEX,1)="" 250 Q 251 ;
Note:
See TracChangeset
for help on using the changeset viewer.
