Changeset 623 for WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMXDT1.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/PXRMXDT1.m
r613 r623 1 PXRMXDT1 ; SLC/PJH - Build Patient list SUBROUTINES;08/16/20072 ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 3 4 5 6 7 NEW(SUB,SUB1,SUB2) 8 9 10 11 12 13 14 15 NEWIP(DFN) 16 17 18 19 20 21 22 NEWP(SUB,DFN) 23 24 25 26 27 28 29 30 NEWT(FACILITY,DFN) 31 32 33 34 35 36 37 38 SDET(DFN,STATUS,NAM,FACILITY,INP) 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 SUM(DFN,STATUS,FACILITY,NAM) 118 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 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 ERRMSG(TYPE);170 171 172 173 174 175 .D SEND^PXRMMSG("REMINDER REPORTS CNBD PATIENT LIST("_$$FMTE^XLFDT($$NOW^XLFDT)_")",1)176 177 178 179 180 181 182 .S ^TMP("PXRMXMZ",$J,1,0)="The Reminders Due Report "_$G(TITLE)_" requested by "_$$GET1^DIQ(200,DUZ,.01)_" on "_$$FMTE^XLFDT($G(PXRMXST))_"was cancelledfor the following reason(s):"183 184 .D SEND^PXRMMSG("Cancelled Reminders Due Report("_$$FMTE^XLFDT($$NOW^XLFDT)_")",1)185 186 1 PXRMXDT1 ; SLC/PJH - Build Patient list SUBROUTINES;07/10/2006 2 ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21 3 ; 4 ; Called by label from PXRMXSEO,PXRMXSE 5 ; 6 ;Combined report duplicate check (Summary report) 7 NEW(SUB,SUB1,SUB2) ; 8 ;Existing entry 9 I $D(^TMP("PXRMCMB",$J,SUB,SUB1,SUB2)) Q 0 10 ;New entry 11 S ^TMP("PXRMCMB",$J,SUB,SUB1,SUB2)="" 12 Q 1 13 ; 14 ;Individual patient report duplicate patient check 15 NEWIP(DFN) ; 16 ;Existing entry 17 I $D(^TMP("PXRMCMB3",$J,DFN)) Q 0 18 ;New entry 19 S ^TMP("PXRMCMB3",$J,DFN)="" 20 Q 1 21 ;Combined report duplicate check (Detail report) 22 NEWP(SUB,DFN) ; 23 ;Existing entry 24 I $D(^TMP("PXRMCMB1",$J,SUB,DFN)) Q 0 25 ;New entry 26 S ^TMP("PXRMCMB1",$J,SUB,DFN)="" 27 Q 1 28 ; 29 ;Combined report duplicate check (Patient totals) 30 NEWT(FACILITY,DFN) ; 31 ;Existing entry 32 I $D(^TMP("PXRMCMB2",$J,FACILITY,DFN)) Q 0 33 ;New entry 34 S ^TMP("PXRMCMB2",$J,FACILITY,DFN)="" 35 Q 1 36 ; 37 ;Detailed report 38 SDET(DFN,STATUS,NAM,FACILITY,INP) ; 39 I $G(^XTMP(PXRMXTMP,PX,FACILITY,NAM))="" D 40 .S ^XTMP(PXRMXTMP,PX,FACILITY,NAM)=NAM 41 ;Applicable 42 S DDAT="N/A" 43 N APPL,FAPPTDT,DEFARR,DNEXT,DNEXT1,FIEV,PXRMDATE,BID,TMPSUB 44 S APPL=0,FAPPTDT=0 45 ;Add any that aren't N/A, Ignore on N/A or NEVER to applicable total 46 I ($P(STATUS,U)'="")&(STATUS'["NEVER")&(STATUS'["N/A")&(STATUS'["ERROR")&(STATUS'["CNBD") S APPL=1 47 ;If DUE NOW save details 48 I $G(STATUS)'["DUE NOW" S PNAM=" " 49 I $G(STATUS)["DUE NOW" D 50 .N BED 51 .S DDUE=$P($G(STATUS),U,2) 52 .S DLAST=$P($G(STATUS),U,3) 53 .;Demographics 54 .S PNAM=$P($G(^DPT(DFN,0)),U),BID=$P($G(^DPT(DFN,0)),U,9) 55 .I PNAM="" S PNAM=" " 56 .E S PNAM=PNAM_U_BID 57 .;Next appointment for location or clinic 58 .;For detailed provider report get next appoint. for assoc. clinic 59 .S DNEXT="" 60 .I PXRMSEL="L"!(PXRMSEL="P") S TMPSUB="PXRM FUTURE APPT" 61 .E S TMPSUB="SDAMA301" 62 .I PXRMFCMB="Y",PXRMLCMB="Y",$D(^TMP($J,TMPSUB,DFN))>0 D 63 ..N APPTCNT,LOC 64 ..S LOC=0,APPTCNT=0 65 ..F S LOC=$O(^TMP($J,TMPSUB,DFN,LOC)) Q:(LOC'>0)!(APPTCNT=1) D 66 ...S DNEXT=$O(^TMP($J,TMPSUB,DFN,LOC,"")) I +DNEXT>0 S APPTCNT=1 Q 67 .S DNEXT=$O(^TMP($J,TMPSUB,DFN,$G(INP),"")) 68 .I PXRMFCMB="N",PXRMLCMB="Y" D 69 ..S DNEXT1=$O(^TMP($J,"PXRM FACILITY FUTURE APPT",DFN,FACILITY,"")) Q:DNEXT1'>0 70 ..I +DNEXT=0!(DNEXT>DNEXT1) S DNEXT=DNEXT1 71 .S BED=$G(^DPT(DFN,.101)) S:BED="" BED="NONE" 72 .;Sort by next appointment date 73 .I PXRMSRT="Y" S DDAT=$P(DNEXT,".") S:DDAT="" DDAT="NONE" 74 .;Patient ward/bed used only for inpatient reports 75 .I PXRMFUT="Y" S DNEXT="" 76 .N TXT 77 .S TXT=DFN_U_DDUE_U_DLAST_U_$G(DNEXT)_$S($G(BED)'="":U_BED,1:"") 78 .I $G(BED)'="",BED'="NONE" S DDAT=BED 79 .N BED 80 .S BED="" 81 .I $G(PXRMINP) D 82 ..S BED=$G(^DPT(DFN,.101)) S:BED="" BED="NONE" 83 ..S TXT=TXT_U_BED 84 ..;Sort by bed 85 ..I PXRMSRT="B" S DDAT=BED 86 .;Duplicate check for combined report 87 .I PXRMFCMB="Y",'$$NEW(NAM,DDAT,PNAM) Q 88 .;I PXRMFCMB'="Y",PXRMLCMB="Y",'$$NEW^PXRMXSEO(NAM,DDAT,PNAM) Q 89 .;Save entry in ^XTMP 90 .S ^XTMP(PXRMXTMP,PX,FACILITY,NAM,DDAT,PNAM)=TXT 91 .;Total of reminders overdue 92 .N CNT 93 .S CNT=$P(^XTMP(PXRMXTMP,PX,FACILITY,NAM),U,2) 94 .S $P(^XTMP(PXRMXTMP,PX,FACILITY,NAM),U,2)=CNT+1 95 ;Total of patients checked/applicable 96 N CNT,NEW 97 S NEW=1 I PXRMFCMB="Y" S NEW=$$NEWP(NAM,DFN) 98 I NEW=1 D 99 .S CNT=$P(^XTMP(PXRMXTMP,PX,FACILITY,NAM),U,3) 100 .S $P(^XTMP(PXRMXTMP,PX,FACILITY,NAM),U,3)=CNT+1 101 .S CNT=$P(^XTMP(PXRMXTMP,PX,FACILITY,NAM),U,4) 102 .S $P(^XTMP(PXRMXTMP,PX,FACILITY,NAM),U,4)=CNT+APPL 103 I PXRMFUT="Y"&($G(STATUS)["DUE NOW") D 104 .N APPTARY,APPTDT,CIEN,CNT,NODE,SUB 105 .S SUB="" I $D(^TMP($J,"PXRM FUTURE APPT",DFN))>0 S SUB="PXRM FUTURE APPT" 106 .I SUB="",$D(^TMP($J,"SDAMA301",DFN))>0 S SUB="SDAMA301" 107 .I SUB="" Q 108 .S CNT=0 109 .S CIEN=0 F S CIEN=$O(^TMP($J,SUB,DFN,CIEN)) Q:CIEN'>0 D 110 ..S APPTDT=0 111 ..F S APPTDT=$O(^TMP($J,SUB,DFN,CIEN,APPTDT)) Q:APPTDT'>0 D 112 ...S NODE=$G(^TMP($J,SUB,DFN,CIEN,APPTDT)) 113 ...S APPTARY(APPTDT)=APPTDT_U_$P($P(NODE,U,2),";",2)_U_$P($P(NODE,U,22),";",2) 114 .S APPTDT=0 F S APPTDT=$O(APPTARY(APPTDT)) Q:APPTDT'>0 S CNT=CNT+1,^XTMP(PXRMXTMP,PX,FACILITY,NAM,DDAT,PNAM,CNT,0)=APPTARY(APPTDT) 115 Q 116 ; 117 SUM(DFN,STATUS,FACILITY,NAM) ; 118 N DUE,EVAL 119 S (DUE,EVAL)=0 120 ;Add dues to totals of reminders due and reminders applicable 121 I STATUS["DUE NOW" D 122 .S DUE=1,EVAL=1 123 ;Add any that aren't N/A, Ignore on N/A,ERROR or NEVER to applicable total 124 S STATUS=$P(STATUS,U) 125 I (STATUS'=" ")&(STATUS'["NEVER")&(STATUS'="N/A")&(STATUS'["ERROR")&(STATUS'["CNBD") S EVAL=1 126 ;Update XTMP - Total of reminders due 127 I "IR"[PXRMTOT D 128 .;Combined facility duplicate check 129 .I PXRMFCMB="Y",'$$NEW(NAM,DFN,ITEM) Q 130 .N CNT 131 .S CNT=$P($G(^XTMP(PXRMXTMP,PX,FACILITY,NAM,ITEM)),U,1) 132 .S $P(^XTMP(PXRMXTMP,PX,FACILITY,NAM,ITEM),U,1)=CNT+EVAL 133 .;Total of reminders evaluated 134 .S CNT=$P($G(^XTMP(PXRMXTMP,PX,FACILITY,NAM,ITEM)),U,2) 135 .S $P(^XTMP(PXRMXTMP,PX,FACILITY,NAM,ITEM),U,2)=CNT+DUE 136 ; 137 ;Totals 138 I "RT"[PXRMTOT D 139 .;Check for duplicate patient at FACILITY level 140 .I $D(^TMP("PXRMDUP",$J,FACILITY,DFN,ITEM)) Q 141 .;Set duplicate check 142 .S ^TMP("PXRMDUP",$J,FACILITY,DFN,ITEM)="" 143 .I $G(^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL"))="" D 144 ..S ^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL")="TOTAL" 145 .N CNT 146 .S CNT=$P($G(^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL",ITEM)),U,1) 147 .S $P(^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL",ITEM),U,1)=CNT+EVAL 148 .S CNT=$P($G(^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL",ITEM)),U,2) 149 .S $P(^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL",ITEM),U,2)=CNT+DUE 150 ; 151 ;Total of patients 152 I "IR"[PXRMTOT D 153 .I PXRMSEL="I",$$NEWIP(DFN)<1 Q 154 .I $$NEWP(@SUB,DFN)=0 Q 155 .I $G(^XTMP(PXRMXTMP,PX,FACILITY,@SUB))="" S ^XTMP(PXRMXTMP,PX,FACILITY,@SUB)=NAM 156 .N CNT S CNT=$P($G(^XTMP(PXRMXTMP,PX,FACILITY,@SUB)),U,3) 157 .S $P(^XTMP(PXRMXTMP,PX,FACILITY,@SUB),U,3)=CNT+1 158 ; 159 ;Total reports 160 I "TR"[PXRMTOT D 161 .I '$$NEWT(FACILITY,DFN) Q 162 .I $G(^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL"))="" D 163 ..S ^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL")=NAM 164 .N CNT 165 .S CNT=$P($G(^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL")),U,3) 166 .S $P(^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL"),U,3)=CNT+1 167 Q 168 ; 169 DBDOWN(TYPE) ; 170 N CNT,CNT1,CNT2,STR,NLINES,OUTPUT,TIME 171 K ^TMP("PXRMXMZ",$J) 172 S NLINES=0,CNT=0,CNT1=2 173 I TYPE="C" D Q 174 .M ^TMP("PXRMXMZ",$J)=^TMP($J,"PXRM CNBD") 175 .D SEND^PXRMMSG("COULD NOT BE DETERMINED PATIENTS("_$$FMTE^XLFDT($$NOW^XLFDT)_")",1) 176 I 'PXRMQUE D 177 .S STR(1)="The Reminders Due Report "_$G(TITLE)_" requested by "_$$GET1^DIQ(200,DUZ,.01)_" on "_$$FMTE^XLFDT($G(PXRMXST))_" for the following reason(s):" 178 .F S CNT=$O(DBERR(CNT)) Q:CNT'>0 S STR(CNT1)="\\"_DBERR(CNT),CNT1=CNT1+1 179 .D FORMAT^PXRMTEXT(1,80,2,.STR,.NLINES,.OUTPUT) 180 .F CNT=1:1:NLINES W !,OUTPUT(CNT) 181 I PXRMQUE D 182 .S ^TMP("PXRMXMZ",$J,1,0)="The Reminders Due Report "_$G(TITLE)_" requested by "_$$GET1^DIQ(200,DUZ,.01)_" on "_$$FMTE^XLFDT($G(PXRMXST))_" for the following reason(s):" 183 .F S CNT=$O(DBERR(CNT)) Q:CNT'>0 S ^TMP("PXRMXMZ",$J,CNT1,0)=DBERR(CNT),CNT1=CNT1+1 184 .D SEND^PXRMMSG("Cancelled Reminders Due Report("_$$FMTE^XLFDT($$NOW^XLFDT)_")",1) 185 .S ZTSTOP=1 186 Q
Note:
See TracChangeset
for help on using the changeset viewer.
