source: WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMXTU.m@ 1006

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

revised back to 6/30/08 version

File size: 5.9 KB
Line 
1PXRMXTU ; SLC/PJH - Reminder Reports Template Update ;11/03/2005
2 ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
3 ;
4 ; Called from PXRMYD,PXRMXD (also at UPD from PXRMXPR/PXRMYPR)
5 ;
6 ;Option to create a new template
7 ;-------------------------------
8START N PXRMASK,MSG D ASK(.PXRMASK)
9 I $G(PXRMASK)="Y" D SAVE
10EXIT Q
11 ;
12 ;Ask name for new template
13 ;-------------------------
14SAVE N X,Y,DIC,DLAYGO
15SAV1 S DIC=810.1,DLAYGO=DIC,DIC(0)="QAELX"
16 S DIC("A")="STORE REPORT LOGIC IN TEMPLATE NAME: "
17 W !
18 D ^DIC
19 I X="" W !,"A template name must be entered" G SAV1
20 I X=(U_U) S DTOUT=1
21 I Y=-1 S DUOUT=1 W !,"Details not saved" Q
22 I $D(DTOUT)!$D(DUOUT) Q
23 ;Check
24 I ($P(Y,U,3)'=1) W !,"This template name already exists" G SAV1
25 ;Get template name and title
26 S PXRMTMP=Y,TITLE=$P($G(^PXRMPT(810.1,$P(Y,U),0)),U,2)
27 S $P(PXRMTMP,U,3)=TITLE
28 ;File details
29 D FILE(Y,1,0)
30 ;File not saved message
31 I $D(MSG) D Q
32 .N DA,DIK
33 .S DA=$P(Y,U),DIK="^PXRMPT(810.1," D ^DIK
34 .D MESS^PXRMXTF(4,$P(PXRMTMP,U,2))
35 ;File saved message
36 D MESS^PXRMXTF(1,$P(PXRMTMP,U,2))
37 Q
38 ;
39 ;File template detail
40 ;--------------------
41FILE(INP,UPD,CLR) ;
42 N CNT,FDA,FDAIEN,FNO,IC,INT,MODE,NAME,X
43 S FDAIEN(1)=$P(INP,U),NAME=$P(INP,U,2)
44 ;Save exit flags - needed for rollback
45 N DUOUT,DTOUT
46 ;
47 ;Update or Add
48 S MODE=$S(UPD:(FDAIEN(1)_","),1:"+1,")
49 ;Delete entries from existing template
50 I CLR D
51 .N DA S DA=0
52 .F S DA=$O(^PXRMPT(810.1,FDAIEN(1),DA)) Q:'DA D
53 ..K ^PXRMPT(810.1,FDAIEN(1),DA)
54 ;
55 I PXRMSEL="L" S X=PXRMLCSC,PXRMLCSC=$P(PXRMLCSC,U)
56 ;
57 N MREF,XREF
58 D XREF^PXRMXTB
59 ;
60 ;Save single fields into FDA
61 F IC="NAME","PXRMLCSC","PXRMPRIM","PXRMREP","PXRMSEL","PXRMTYP" D
62 .S FDA(810.1,MODE,XREF(IC))=$G(@IC)
63 F IC="PXRMFD","PXRMSCAT","RUN","TITLE" D
64 .S FDA(810.1,MODE,XREF(IC))=$G(@IC)
65 ;
66 I PXRMSEL="L" S PXRMLCSC=X
67 ;
68 ;Save Arrays into FDA
69 ;
70 ;Reminder Items
71 S CNT=1
72 D SUB1(.PXRMREM,"810.12",1)
73 ;Save Facility codes
74 D SUB1(.PXRMFAC,"810.13",1)
75 ;Save Provider codes
76 D SUB1(.PXRMPRV,"810.14",1)
77 ;Save Patient codes
78 D SUB1(.PXRMPAT,"810.16",1)
79 ;Save OE/RR Team codes
80 D SUB1(.PXRMOTM,"810.17",1)
81 ;Save PCMM Team codes
82 D SUB1(.PXRMPCM,"810.18",1)
83 ;Save Hospital Location codes
84 D SUB1(.PXRMLCHL,"810.11",2)
85 ;Save Clinic Stop codes
86 D SUB1(.PXRMCS,"810.111",2)
87 ;Save Clinic groups
88 D SUB1(.PXRMCGRP,"810.112",1)
89 ;Save Reminder Categories
90 D SUB1(.PXRMRCAT,"810.113",1)
91 ;Save Patient lists
92 D SUB1(.PXRMLIST,"810.114",1)
93 ;
94 ;Update template file
95 D UPDATE^DIE("S","FDA","FDAIEN","MSG")
96 ;
97 I $D(MSG) D
98 .W !!,"Update failed, UPDATE^DIE returned the following error message:"
99 .S IC="MSG"
100 .F S IC=$Q(@IC) Q:IC="" W !,IC,"=",@IC
101 .W !,"Examine the above error message for the reason.",!
102 .H 2
103 Q
104 ;
105 ;Save arrays into FDA
106 ;--------------------
107SUB1(OUTPUT,VAR,PIECE) ;
108 S IC=""
109 ;This is use for saving individual reminders back to the original
110 ;template
111 I VAR=810.12,$D(PXRMTREM($P(INP,U)))>0 D Q
112 .F S IC=$O(PXRMTREM($P(INP,U),IC)) Q:IC="" D
113 ..S INT=$P(PXRMTREM($P(INP,U),IC),U,PIECE),CNT=CNT+1
114 ..S FDA(VAR,"+"_CNT_","_MODE,.01)=INT
115 ..S FDA(VAR,"+"_CNT_","_MODE,.02)=IC
116 ;
117 ;This is use for saving individual reminders category back to the
118 ;original template
119 I VAR=810.113,$D(PXRMTCAT($P(INP,U)))>0 D Q
120 .F S IC=$O(PXRMTCAT($P(INP,U),IC)) Q:IC="" D
121 ..S INT=$P(PXRMTCAT($P(INP,U),IC),U,PIECE),CNT=CNT+1
122 ..S FDA(VAR,"+"_CNT_","_MODE,.01)=INT
123 ..S FDA(VAR,"+"_CNT_","_MODE,.02)=IC
124 ;
125 ;this is use for saving everything else to the template
126 F S IC=$O(OUTPUT(IC)) Q:IC="" D
127 .S INT=$P(OUTPUT(IC),U,PIECE),CNT=CNT+1
128 .S FDA(VAR,"+"_CNT_","_MODE,.01)=INT
129 .;Save Display order for reminders and categories
130 .I (VAR=810.12)!(VAR=810.113) S FDA(VAR,"+"_CNT_","_MODE,.02)=IC
131 Q
132 ;
133 ;Save Service Categories into FDA
134 ;--------------------------------
135SUB2(FLD,VAR) ;
136 F IC=1:1 S INT=$E(@FLD,IC) Q:INT="" D
137 .S CNT=CNT+1,FDA(VAR,"+"_CNT_","_MODE,.01)=INT
138 Q
139 ;
140 ;
141 ;Option to save a new template
142 ;-----------------------------
143ASK(YESNO) ;
144 N X,Y,TEXT
145 K DIROUT,DIRUT,DTOUT,DUOUT
146 S DIR(0)="YA0"
147 S DIR("A")="Create a new report template: "
148 S DIR("B")="N"
149 S DIR("?")="Enter Y or N. For detailed help type ??"
150 S DIR("??")=U_"D HELP^PXRMXTU(1)"
151 W !
152 D ^DIR K DIR
153 I $D(DIROUT) S DTOUT=1
154 I $D(DTOUT)!($D(DUOUT)) Q
155 S YESNO=$E(Y(0))
156 Q
157 ;
158 ;General help text routine. Write out the text in the HTEXT array
159 ;----------------------------------------------------------------
160HELP(CALL) ;
161 N HTEXT
162 N DIWF,DIWL,DIWR,IC
163 S DIWF="C70",DIWL=0,DIWR=70
164 ;
165 I CALL=1 D
166 .S HTEXT(1)="Enter 'Y' to save the reporting parameters as a report"
167 .S HTEXT(2)="template from which the report may be re-run in future."
168 ;
169 K ^UTILITY($J,"W")
170 S IC=""
171 F S IC=$O(HTEXT(IC)) Q:IC="" D
172 . S X=HTEXT(IC)
173 . D ^DIWP
174 W !
175 S IC=0
176 F S IC=$O(^UTILITY($J,"W",0,IC)) Q:IC="" D
177 . W !,^UTILITY($J,"W",0,IC,0)
178 K ^UTILITY($J,"W")
179 W !
180 Q
181 ;
182 ;Save template info to new name
183 ;------------------------------
184COPY N PXRMLCSC,PXRMPRIM,PRRMREP,PXRMSEL,PXRMTYP,PXRMFD,RUN,PXRMCS
185 N PXRMREM,PXRMFAC,PXRMPRV,PXRMPAT,PXRMOTM,PXRMSCAT,PXRMLCHL,PXRMCS
186 ;Load arrays from original template PXRMTMP
187 D LOAD^PXRMXT I $D(MSG) Q
188 ;Clear last run date
189 S RUN=""
190 ;Save arrays to new ID
191 D FILE(NEWTEMP,0)
192 Q
193 ;
194 ;Update print template last run date (called from PXRMYPR/PXRMXPR)
195 ;-----------------------------------------------------------------
196UPD S ^PXRMPT(810.1,$P(PXRMTMP,U),7)=PXRMXST
197 Q
198 ;
199 ;Called as an input transform for 810.1/NAME
200 ;-------------------------------------------
201NAME Q:'$D(X) Q:X="" Q:$G(PXRMTYP)=""
202 ;Disallow duplicate template names
203 Q:'$D(^PXRMPT(810.1,"B",X))
204 W !,"This template name already exists" K X
205 Q
206 ;
207 ;Called as an input transform for 810.1/PXRMFD
208 ;---------------------------------------------
209INP Q:'$D(X) Q:X=""
210 ;If inpatient wards prompt only for Admissions/Current Patients
211 I $G(PXRMINP),"FP"[X D
212 .W !,"Select either Inpatient Admissions or Current Inpatients" K X
213 ;If other locations prompt only for Prior visits/Future Appts
214 I '$G(PXRMINP),"AC"[X D
215 .W !,"Select either Future Appointments or Prior Visits" K X
216 Q
Note: See TracBrowser for help on using the repository browser.