Changeset 623 for WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMINDX.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/PXRMINDX.m
r613 r623 1 PXRMINDX ; SLC/PKR - Routines for utilizing the index. ;10/11/20072 ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 3 4 5 EVALFI(DFN,DEFARR,ENODE,FIEVAL) 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL) 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 FIEVAL(FILENUM,SNODE,DFN,ITEM,PFINDPA,FIEVAL) 51 52 53 54 55 56 57 58 59 60 S NGET=$S(UCIFS:50,1:NOCC)61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 . I PFINDPA(0)["YTT(601.71" S DAS=DAS_"S"_$P(PFINDPA(0),U,12)78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 FPDAT(FILENUM,SNODE,DFN,ITEM,NGET,SDIR,BDT,EDT,NFOUND,FLIST) 101 102 103 I FILENUM=601.84D SEVALFI^PXRMMH(DFN,ITEM,NGET,SDIR,BDT,EDT,.NFOUND,.FLIST) Q104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 FPDATSS(FILENUM,SNODE,DFN,ITEM,NGET,SDIR,BDT,EDT,USESTRT,NFOUND,FLIST) 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 OVERLAP(START,STOP,BDT,EDT) 150 151 152 153 154 155 156 157 158 STATUSOK(STATUSA,FIEVD) 159 160 161 162 163 164 165 166 167 1 PXRMINDX ; SLC/PKR - Routines for utilizing the index. ;07/17/2006 2 ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21 3 ;Code for patient findings. 4 ;================================================================ 5 EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;General finding evaluator. 6 N BDT,EDT,FIEVT,FILENUM,FINDING,FINDPA,ITEM,NOINDEX 7 S FILENUM=$$GETFNUM^PXRMDATA(ENODE) 8 I $G(^PXRMINDX(FILENUM,"DATE BUILT"))="" D 9 . D NOINDEX^PXRMERRH("D",PXRMITEM,FILENUM) 10 . S NOINDEX=1 11 E S NOINDEX=0 12 S ITEM="" 13 F S ITEM=$O(DEFARR("E",ENODE,ITEM)) Q:ITEM="" D 14 . S FINDING="" 15 . F S FINDING=$O(DEFARR("E",ENODE,ITEM,FINDING)) Q:+FINDING=0 D 16 .. I NOINDEX S FIEVAL(FINDING)=0 Q 17 .. K FINDPA 18 .. M FINDPA=DEFARR(20,FINDING) 19 .. K FIEVT 20 .. D FIEVAL(FILENUM,"PI",DFN,ITEM,.FINDPA,.FIEVT) 21 .. M FIEVAL(FINDING)=FIEVT 22 .. S FIEVAL(FINDING,"FINDING")=$P(FINDPA(0),U,1) 23 Q 24 ; 25 ;================================================================ 26 EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL) ;General term 27 ;evaluator. 28 N FIEVT,FILENUM,ITEM,NOINDEX,PFINDPA 29 N TFINDING,TFINDPA 30 S FILENUM=$$GETFNUM^PXRMDATA(ENODE) 31 I $G(^PXRMINDX(FILENUM,"DATE BUILT"))="" D 32 . D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),FILENUM) 33 . S NOINDEX=1 34 E S NOINDEX=0 35 S ITEM="" 36 F S ITEM=$O(TERMARR("E",ENODE,ITEM)) Q:+ITEM=0 D 37 . S TFINDING="" 38 . F S TFINDING=$O(TERMARR("E",ENODE,ITEM,TFINDING)) Q:+TFINDING=0 D 39 .. I NOINDEX S TFIEVAL(TFINDING)=0 Q 40 .. K FIEVT,PFINDPA,TFINDPA 41 .. M TFINDPA=TERMARR(20,TFINDING) 42 ..;Set the finding parameters. 43 .. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA) 44 .. D FIEVAL(FILENUM,"PI",DFN,ITEM,.PFINDPA,.FIEVT) 45 .. M TFIEVAL(TFINDING)=FIEVT 46 .. S TFIEVAL(TFINDING,"FINDING")=$P(TFINDPA(0),U,1) 47 Q 48 ; 49 ;================================================================ 50 FIEVAL(FILENUM,SNODE,DFN,ITEM,PFINDPA,FIEVAL) ; 51 ;Evaluate regular patient findings. 52 N BDT,CASESEN,COND,CONVAL,DAS,DATE,EDT,FIEVD,FLIST,ICOND,IEN,IND,INVFD 53 N NFOUND,NGET,NOCC,NP 54 N SAVE,SDIR,SSFIND,STATOK,STATUSA,UCIFS,USESTRT,VSLIST 55 ;Set the finding search parameters. 56 D SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT) 57 D SCPAR^PXRMCOND(.PFINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST) 58 S SDIR=$S(NOCC<0:+1,1:-1) 59 S NOCC=$S(NOCC<0:-NOCC,1:NOCC) 60 S NGET=$S(UCIFS:"*",1:NOCC) 61 ;Determine if this is a finding with a start and stop date. 62 S SSFIND=$S(FILENUM=52:1,FILENUM["55":1,FILENUM=100:1,1:0) 63 S USESTRT=$S(SSFIND:$P(PFINDPA(0),U,15),1:0) 64 I FILENUM=100,USESTRT="" S USESTRT=1 65 ;Get the status list. 66 D GETSTATI^PXRMSTAT(FILENUM,.PFINDPA,.STATUSA) 67 I SSFIND D FPDATSS(FILENUM,SNODE,DFN,ITEM,NGET,SDIR,BDT,EDT,USESTRT,.NFOUND,.FLIST) 68 I 'SSFIND D FPDAT(FILENUM,SNODE,DFN,ITEM,NGET,SDIR,BDT,EDT,.NFOUND,.FLIST) 69 I NFOUND=0 S FIEVAL=0 Q 70 S INVFD=$P(PFINDPA(0),U,16) 71 S NP=0 72 F IND=1:1:NFOUND Q:NP=NOCC D 73 . S DAS=$P(FLIST(IND),U,1) 74 .;If this a Lab finding attach the item to the DAS. 75 . I PFINDPA(0)["LAB(60" S DAS=ITEM_"~"_DAS 76 .;If this is a Mental Health finding attach the scale to DAS. 77 . I PFINDPA(0)["YTT(601" S DAS=DAS_"S"_$P(PFINDPA(0),U,12) 78 . D GETDATA^PXRMDATA(FILENUM,DAS,.FIEVD) 79 . I INVFD D GETDATA^PXRMVSIT(FIEVD("VISIT"),.FIEVD,0) 80 .;If there is a status list make sure the finding has one on the list. 81 . S STATOK=$S($D(STATUSA):$$STATUSOK(.STATUSA,.FIEVD),1:1) 82 . I 'STATOK Q 83 . S CONVAL=$S(COND'="":$$COND^PXRMCOND(CASESEN,ICOND,VSLIST,.FIEVD),1:1) 84 . S SAVE=$S('UCIFS:1,(UCIFS&CONVAL):1,1:0) 85 . I SAVE D 86 .. S NP=NP+1 87 .. S FIEVAL(NP)=CONVAL 88 .. I COND'="" S FIEVAL(NP,"CONDITION")=CONVAL 89 .. S FIEVAL(NP,"DAS")=$P(FLIST(IND),U,1) 90 .. S FIEVAL(NP,"DATE")=$P(FLIST(IND),U,2) 91 .. M FIEVAL(NP)=FIEVD 92 .. I $G(PXRMDEBG) M FIEVAL(NP,"CSUB")=FIEVD 93 ; 94 ;Save the finding result. 95 D SFRES^PXRMUTIL(SDIR,NP,.FIEVAL) 96 S FIEVAL("FILE NUMBER")=FILENUM 97 Q 98 ; 99 ;================================================================ 100 FPDAT(FILENUM,SNODE,DFN,ITEM,NGET,SDIR,BDT,EDT,NFOUND,FLIST) ;Find patient 101 ;data for regular files. FLIST is returned in date order, i.e., 102 ;FLIST(1) is the most recent SDIR=-1, oldest SDIR=+1. 103 I FILENUM=601.2 D SEVALFI^PXRMMH(DFN,ITEM,NGET,SDIR,BDT,EDT,.NFOUND,.FLIST) Q 104 N DAS,DATE,DONE,EDTT 105 S EDTT=$S(EDT[".":EDT+.0000001,1:EDT+.240001) 106 S (DONE,NFOUND)=0 107 S DATE=$S(SDIR=+1:BDT-.000001,1:EDTT) 108 F S DATE=+$O(^PXRMINDX(FILENUM,SNODE,DFN,ITEM,DATE),SDIR) Q:(DATE=0)!(DONE) D 109 . I DATE<BDT,SDIR=-1 S DONE=1 Q 110 . I DATE>EDTT,SDIR=1 S DONE=1 Q 111 . S DAS=$O(^PXRMINDX(FILENUM,SNODE,DFN,ITEM,DATE,"")) 112 . S NFOUND=NFOUND+1 113 . S FLIST(NFOUND)=DAS_U_DATE 114 . I NFOUND=NGET S DONE=1 Q 115 Q 116 ; 117 ;================================================================ 118 FPDATSS(FILENUM,SNODE,DFN,ITEM,NGET,SDIR,BDT,EDT,USESTRT,NFOUND,FLIST) ;Find 119 ;patient data for findings that have a start and stop date. FLIST 120 ;is returned in date order, i.e., FLIST(1) is the most recent. 121 N DAS,DONE,EDTT,OVERLAP,SDATE,START,STOP,TDATE,TIND,TLIST 122 S EDTT=$S(EDT[".":EDT+.0000001,1:EDT+.240001) 123 S (DONE,NFOUND)=0 124 S START=$S(SDIR=+1:0,1:EDTT) 125 F S START=+$O(^PXRMINDX(FILENUM,SNODE,DFN,ITEM,START),SDIR) Q:(START=0)!(DONE)!(START>EDTT) D 126 . S STOP="" 127 . F S STOP=$O(^PXRMINDX(FILENUM,SNODE,DFN,ITEM,START,STOP),SDIR) Q:(STOP="")!(DONE) D 128 ..;Items that do not have a stop date are flagged by "U". 129 .. S SDATE=$S(USESTRT:START,STOP["U":$$NOW^PXRMDATE_"U",1:STOP) 130 .. S OVERLAP=$$OVERLAP(START,SDATE,BDT,EDT) 131 .. I OVERLAP="O" D 132 ... S DAS=$O(^PXRMINDX(FILENUM,SNODE,DFN,ITEM,START,STOP,"")) 133 ... S NFOUND=NFOUND+1,TLIST(SDATE,NFOUND)=DAS_U_SDATE 134 ..;Some orders and non-VA meds may not have a Stop Date so we have 135 ..;to check all entries. 136 .. I FILENUM="55NVA" Q 137 .. I FILENUM=100 Q 138 .. I OVERLAP="L",SDIR=-1 S DONE=1 Q 139 .. I OVERLAP="R",SDIR=1 S DONE=1 Q 140 ;Return up to NGET of the most recent/oldest entries. 141 S NFOUND=0,TDATE="" 142 F S TDATE=$O(TLIST(TDATE),SDIR) Q:(TDATE="")!(NFOUND=NGET) D 143 . S TIND=0 144 . F S TIND=$O(TLIST(TDATE,TIND)) Q:(TIND="")!(NFOUND=NGET) D 145 .. S NFOUND=NFOUND+1,FLIST(NFOUND)=TLIST(TDATE,TIND) 146 Q 147 ; 148 ;================================================================ 149 OVERLAP(START,STOP,BDT,EDT) ;Determine if the date range defined by START and 150 ;STOP overlaps with the date range defined by BDT and EDT. The return 151 ;value "O" means they overlap, "L" means START, STOP is to the 152 ;left of BDT, EDT and "R" means it is to the right. 153 I EDT<START Q "R" 154 I STOP<BDT Q "L" 155 Q "O" 156 ; 157 ;================================================================ 158 STATUSOK(STATUSA,FIEVD) ;Return true if the status in FIEVD matches one in 159 ;the list in STATUSA. 160 I '$D(FIEVD("STATUS")) Q 1 161 N JND,OK 162 S OK=0 163 F JND=1:1:STATUSA(0) Q:OK D 164 . I STATUSA(JND)="*" S OK=1 Q 165 . I STATUSA(JND)=FIEVD("STATUS") S OK=1 Q 166 Q OK 167 ;
Note:
See TracChangeset
for help on using the changeset viewer.
