source: WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMXSE1.m@ 1361

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

revised back to 6/30/08 version

File size: 6.5 KB
Line 
1PXRMXSE1 ; SLC/PJH - Build Patient lists for Reminder Due report; 01/25/2006
2 ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
3 ;
4 ; Called/jobbed from PXRMXD
5 ;
6 ; Input - PXRMSEL,PXRMXTMP
7 ; PXRM*
8 ; Output- ^XTMP(PXRMXTMP
9 ;
10 ;
11START ;
12 N LIT,TOTAL,TODAY,ZTSTOP,BUSY
13 S DBDOWN=0
14 S TOTAL=0,ZTSTOP="",TODAY=$$DT^XLFDT-.0001
15 ;
16 K ^TMP($J,"PXRM PATIENT LIST"),^TMP($J,"PXRM PATIENT EVAL")
17 K ^TMP($J,"PXRM FUTURE APPT"),^TMP($J,"SDAMA301")
18 K ^TMP($J),^TMP(PXRMRT,$J),^TMP("PXRMDUP",$J)
19 K ^TMP("PXRMCMB",$J),^TMP("PXRMCMB1",$J),^TMP("PXRMCMB2",$J)
20 N PXRMRERR
21 ;
22 I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY)
23 ;
24 ;OE/RR team selected (PXRMOTM)
25 I PXRMSEL="O" D OERR^PXRMXSL1
26 ;
27 ;PCMM team selected (PXRMPCM)
28 I PXRMSEL="T" D PCMMT^PXRMXSL1
29 ;
30 N HLIEN,FACILITY
31 ;Location selected (PXRMLCHL,PXRMCGRP)
32 I PXRMSEL="L" D G:ZTSTOP=1 EXIT
33 .;Build Clinic List
34 .D BHLOC^PXRMXSL1
35 .;Prior Visits - build patient list in ^TMP
36 .I PXRMFD="P" D VISITS^PXRMXSL2 I DBDOWN=1 Q
37 .;Inpatient Admissions and current inpatient locations
38 .I PXRMFD="A"!(PXRMFD="C") D INPADM^PXRMXSL1
39 .;Future Appointments - build patient list in ^TMP
40 .I PXRMFD="F" D APPTS^PXRMXSL2 I DBDOWN=1 Q
41 .;End task requested
42 .Q:ZTSTOP=1
43 ;Update ^XTMP from ^TMP
44 I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY)
45 ;
46 ;PCMM provider selected (PXRMPRV)
47 I PXRMSEL="P" D PCMMP^PXRMXSL1
48 ;
49 ;Individual Patients selected (PXRMPAT)
50 I PXRMSEL="I" D IND^PXRMXSL1
51 ;
52 ;Patient List selected (PXRMLIST)
53 I PXRMSEL="R" D LIST^PXRMXSL1
54 ;
55 I DBDOWN=1 G EXIT
56 S START=$H
57 D EVAL^PXRMXEVL("PXRM PATIENT EVAL",.REMINDER)
58 D XTMP(START)
59 ;
60 ;Update patient list
61 I PXRMSEL'="I"&(PXRMUSER'="Y")&($G(PXRMLIS1)'="") D
62 .;If no patients due delete patient list
63 .I +$O(^TMP($J,"PXRMXPAT",""))=0 D Q
64 ..N DA,DIK S DA=PXRMLIS1,DIK="^PXRMXP(810.5," D ^DIK
65 .;Otherwise create patient list
66 .D UPDLST^PXRMRULE("PXRMXPAT",PXRMLIS1,"","")
67 .S $P(^PXRMXP(810.5,PXRMLIS1,0),U,9)=1
68 K ^TMP($J,"PXRMXPAT")
69 K ^TMP($J),^TMP(PXRMRT,$J),^TMP("PXRMDUP",$J)
70 K ^TMP("PXRMCMB",$J),^TMP("PXRMCMB1",$J),^TMP("PXRMCMB2",$J),^TMP("PXRMCMB3",$J)
71 K DBDOWN
72 ;
73DONE ;
74 ;Sorting is done.
75 I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) W ! D DONE^PXRMXBSY("done")
76 ;
77 ;I PXRMDBUG="Y" D DEBUG("End of evaluation:",PXRMREP,"^XTMP(PXRMXTMP,PX)")
78 ;Print the report information.
79 I PXRMQUE D Q
80 .;Start the printing that was queued but not scheduled.
81 .N DESC,ROUTINE,TASK
82 .S ROUTINE="^PXRMXPR"
83 .S DESC="Reminder Due Report - print"
84 .S TASK=$G(^XTMP(PXRMXTMP,"PRZTSK"))
85 .I TASK="" D NOPRZTSK(PXRMXTMP) Q
86 .D REQUE^PXRMXQUE(DESC,ROUTINE,TASK)
87 .S ZTREQ="@"
88 I 'PXRMQUE D ^PXRMXPR
89 Q
90 ;
91AWRITE(REF,LS) ;This line tag is a copy of AWRITE^PXRMUTIL
92 N CNT,DONE,IC,IND,LEN,PROOT,ROOT,START,TEMP
93 I REF="" Q
94 S PROOT=$P(REF,")",1)
95 S TEMP=$NA(@REF)
96 S ROOT=$P(TEMP,")",1)
97 S REF=$Q(@REF)
98 I REF'[ROOT Q
99 S DONE=0,CNT=LS
100 F IC=0:0 Q:(REF="")!(DONE) D
101 . S START=$F(REF,ROOT)
102 . S LEN=$L(REF)
103 . S IND=$E(REF,START,LEN)
104 . S CNT=CNT+1,^TMP("PXRMXMZ",$J,CNT,0)=PROOT_IND_"="_@REF
105 . S REF=$Q(@REF)
106 . I REF'[ROOT S DONE=1
107 Q
108 ;
109DEBUG(LOC,TYPE,REF) ;
110 N CNT,DDAT,FACILITY,HEADER,PNAM,PX,SUB
111 K ^TMP("PXRMXMZ",$J)
112 S PX="PXRM"
113 I TYPE'="P"&(TYPE'="DEBUG") D Q
114 .D AWRITE(REF,0)
115 .D SEND^PXRMMSG("Debug output: "_LOC_" Reminder Report type "_TYPE_" ("_$$NOW^XLFDT_")",DUZ)
116 D AWRITE(REF,0)
117 S HEADER=LOC_" ("_$$NOW^XLFDT_")"
118 D SEND^PXRMMSG("Debug output: "_HEADER,DUZ)
119 Q
120 ;
121ERROR(STATUS,ITEM) ;
122 ;Create XTMP entry for Reminders that error out or could not be
123 ;determing on evaluation
124 N ERRNAME
125 S STATUS=$P(STATUS,U)
126 S ERRNAME=$P(^PXD(811.9,ITEM,0),U)
127 I $D(^XTMP(PXRMXTMP,STATUS,ERRNAME))>0,^XTMP(PXRMXTMP,STATUS,ERRNAME)>0 D
128 .S ^XTMP(PXRMXTMP,STATUS,ERRNAME)=^XTMP(PXRMXTMP,STATUS,ERRNAME)+1
129 E S ^XTMP(PXRMXTMP,STATUS,ERRNAME)=1
130 Q
131 ;
132 ;End Task requested
133EXIT ;
134 S ZTSK=$G(^XTMP(PXRMXTMP,"PRZTSK"))
135 I ZTSK>0 D KILL^%ZTLOAD
136 D EXIT^PXRMXGUT
137 K DBDOWN
138 Q
139 ;
140NOPRZTSK(PXRMXTMP) ;Could not get PRZTSK send an error message
141 N TEXT
142 K ^TMP("PXRMXMZ",$J)
143 S TEXT(1,0)="The task number for the print job cannot be determined."
144 S TEXT(2,0)="The reason is:"
145 I '$D(^XTMP(PXRMXTMP)) S TEXT(3,0)=" The ^XTMP(PXRMXTMP) global is not defined."
146 I $D(^XTMP(PXRMXTMP)),'$D(^XTMP(PXRMXTMP,"PRZTSK")) S TEXT(3,0)=" ^XTMP(PXRMXTMP,""PRZTSK"") does not exist."
147 I $D(^XTMP(PXRMXTMP,"PRZTSK")) S TEXT(3,0)=" ^XMTP(PXRMXTMP,""PRZTSK"") is null."
148 S TEXT(4,0)="PXRMXTMP="_PXRMXTMP
149 M ^TMP("PXRMXMZ",$J)=TEXT
150 D SEND^PXRMMSG("REMINDER REPORT ERROR",DUZ)
151 Q
152 ;
153XTMP(START) ;
154 N CNT,CCNT,DDAT,INP,ITEM,LIT,LSSN,MCNBD,MCNBDR,NAME,SUB,STATUS,TEMP,TEMP1
155 K ^TMP($J,"PXRM CNBD")
156 S CCNT=0,MCNBD=$G(^PXRM(800,1,"MIERR")),MCNBDR=0
157 ;I PXRMDBUG="Y" D DEBUG("PATIENT DATA","P","^TMP($J,""PXRM PATIENT EVAL"")")
158 S BUSY=0,SUB="NAM",TEMP=0,PX="PXRM"
159 N DDAT,DDUE,DEMARR,DFN,DLAST,DNEXT,FACILITY,NAM,PNAM
160 S FACILITY="",DDAT="N/A"
161 F S FACILITY=$O(^TMP(PXRMRT,$J,FACILITY)) Q:FACILITY="" D
162 .S NAM=""
163 .F S NAM=$O(^TMP(PXRMRT,$J,FACILITY,NAM)) Q:NAM="" D
164 ..S DFN="" F S DFN=$O(^TMP(PXRMRT,$J,FACILITY,NAM,DFN)) Q:DFN="" D
165 ...I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D SPIN^PXRMXBSY("Evaluating Reminders",.BUSY)
166 ...S INP=$G(^TMP(PXRMRT,$J,FACILITY,NAM,DFN))
167 ...S CNT=0 F S CNT=$O(REMINDER(CNT)) Q:CNT'>0 D
168 ....S ITEM=$P(REMINDER(CNT),U,1),LIT=$P(REMINDER(CNT),U,4)
169 ....I LIT="" S LIT=$P(REMINDER(CNT),U,2)
170 ....S STATUS=$G(^TMP($J,"PXRM PATIENT EVAL",DFN,ITEM))
171 ....I STATUS="" Q
172 ....I STATUS["ERROR"!(STATUS["CNBD") D
173 .....D ERROR(STATUS,ITEM) I STATUS["ERROR"!(MCNBDR=1) Q
174 .....I CCNT=0 D Q
175 ......S ^TMP($J,"PXRM CNBD",1,0)=$$RJ^XLFSTR(" ",5)_$$LJ^XLFSTR("PATIENT NAME",30)_$$RJ^XLFSTR("LAST 4",10)
176 ......S (TEMP,TEMP1)=""
177 ......F X=1:1:30 S TEMP=TEMP_"_"
178 ......F X=1:1:6 S TEMP1=TEMP1_"_"
179 ......S ^TMP($J,"PXRM CNBD",2,0)=$$RJ^XLFSTR(" ",5)_$$LJ^XLFSTR(TEMP,30)_$$RJ^XLFSTR(TEMP1,10)
180 ......S CCNT=2
181 .....S CCNT=CCNT+1
182 .....I CCNT>MCNBD S MCNBDR=1 Q
183 .....S NAME=$P(^DPT(DFN,0),U)
184 .....S LSSN=$E($P(^DPT(DFN,0),U,9),6,9)
185 .....S ^TMP($J,"PXRM CNBD",CCNT,0)=$$RJ^XLFSTR(" ",5)_$$LJ^XLFSTR(NAME,30)_$$RJ^XLFSTR(LSSN,10)
186 ....;Add reminder status to patient list TMP Global
187 ....I STATUS["DUE NOW" S ^TMP($J,"PXRMXPAT",DFN,"REM",ITEM)=ITEM_U_STATUS
188 ....I PXRMREP="D" D SDET^PXRMXDT1(DFN,STATUS,NAM,FACILITY,INP)
189 ....I PXRMREP="S" D SUM^PXRMXDT1(DFN,STATUS,FACILITY,NAM)
190 I $D(^TMP($J,"PXRM CNBD"))>0 D DBDOWN^PXRMXDT1("C")
191 K ^TMP($J,"PXRM CNBD")
192 S END=$H
193 I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DETIME^PXRMXSL1(START,END,"Evaluating Reminders")
194 ;I PXRMDBUG="Y" D DEBUG("DEBUG PATIENT DATA EVALUATION","DEBUG","^TMP($J,""PXRMDEBUG"")")
195 K ^TMP($J,"PXRM PATIENT EVAL")
196 Q
197 ;
Note: See TracBrowser for help on using the repository browser.