source: FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMXDT1.m@ 1801

Last change on this file since 1801 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 6.7 KB
Line 
1PXRMXDT1 ; SLC/PJH - Build Patient list SUBROUTINES;08/16/2007
2 ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
3 ;
4 ; Called by label from PXRMXSEO,PXRMXSE
5 ;
6 ;Combined report duplicate check (Summary report)
7NEW(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
15NEWIP(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)
22NEWP(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)
30NEWT(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
38SDET(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 ;
117SUM(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 ;
169ERRMSG(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("REMINDER REPORTS CNBD PATIENT LIST ("_$$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))_"was cancelled 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 TracBrowser for help on using the repository browser.