source: FOIAVistA/trunk/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBAB82.m

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

initial load of FOIAVistA 6/30/08 version
File size: 9.0 KB
Line 
1DVBAB82 ;ALB - CAPRI DVBA REPORTS;03/08/02
2 ;;2.7;AMIE;**42,90,100,119**;Apr 10, 1995;Build 10
3 Q
4 ;
5START(MSG,RPID,PARM) ; CALLED BY REMOTE PROCEDURE DVBAB REPORTS
6 ;Parameters
7 ;=============
8 ; MSG : Output - ^TMP("DVBA",$J)
9 ; RPID : Report Identification Number
10 ; PARM : Input parameters separated by "^"
11 ;
12 N DVBHFS,DVBERR,DVBGUI,I
13 K ^TMP("DVBA",$J)
14 S DVBGUI=1,DVBERR=0,DVBHFS=$$HFS(),RPID=$G(RPID)
15 I RPID<1!(RPID>9) S ^TMP("DVBA",$J,1)="0^Undefined Report ID" G END
16 D HFSOPEN("DVBRP",DVBHFS,"W") I DVBERR G END
17 I RPID=1 D CRMS G END
18 I RPID=3 D CPRNT G END
19 D CHECK I DVBERR G END
20 I RPID=2 D CRRR G END
21 I RPID=4 D CRPON G END
22 I RPID=5 D CIRPT G END
23 I RPID=6 D DSRP G END
24 I RPID=7 D SDPP G END
25 I RPID=8 D SPRPT G END
26 I RPID=9 D VIEW
27 ;
28END D HFSCLOSE("DVBRP",DVBHFS)
29 S I=0 F S I=$O(^TMP("DVBA",$J,1,I)) Q:'I S ^TMP("DVBA",$J,1,I)=^TMP("DVBA",$J,1,I)_$C(13) S:^(I)["$END" ^(I)=""
30 S MSG=$NA(^TMP("DVBA",$J))
31 Q
32CHECK ; VALIDATE INPUT PARAMETERS
33 I $G(PARM)="" S DVBERR=1,^TMP("DVBA",$J,1)="0^Undefined Input Parameters"
34 Q
35 ;
36SDPP ; Report # 7 - Full (Patient Profile MAS) Report
37 ;Parameters
38 ;=============
39 ; DFN : Patient Identification Number
40 ; SDR : R/Range or A/All
41 ; SDBD : Begining date
42 ; SDED : Ending date
43 ; SDP : Print the profile? 1 OR 0
44 ; SDTYP(2) : Print appointments? 1 OR 0
45 ; SDTYP(1) : Print add/edits? 1 or 0
46 ; SDTYP(4) : Print enrollments? 1 or 0
47 ; SDTYP(3) : Print dispositions? 1 OR 0
48 ; SDTYP(7) : Print team information? 1 OR 0
49 ; SDTYP(5) : Print means test? 1 OR 0
50 ;
51 N SDTYP,SDBD,SDED,SDACT,SDPRINT,SDYES,SDRANGE,SDBEG,SDEN
52 S DFN=$P(PARM,"^",1),SDR=$P(PARM,"^",2),SDBD=$P(PARM,"^",3),SDED=$P(PARM,"^",4)
53 S SDP=$P(PARM,"^",5),SDTYP(2)=$P(PARM,"^",6),SDTYP(1)=$P(PARM,"^",7)
54 S SDTYP(4)=$P(PARM,"^",8),SDTYP(3)=$P(PARM,"^",9),SDTYP(7)=$P(PARM,"^",10),SDTYP(5)=$P(PARM,"^",11)
55 D VAL Q:DVBERR
56 S SDACT="",(SDYES,SDRANGE,SDPRINT)=0
57 I SDR="R" S SDRANGE=1
58 I SDP=1 S SDYES=1,SDPRINT=1
59 I 'SDRANGE S (SDBD,SDBEG)=2800101,(SDED,SDEND)=$$ENDDT(),SDHDR=1
60 D ENS^%ZISS
61 N SDYN,DVB S SDPRINT=1,DVB(1)=SDBD_";"_SDED,DVB(4)=DFN,DVB("FLDS")=1
62 ;I $$SDAPI^SDAMA301(.DVB)>0 D
63 I $O(^DPT(DFN,"S",SDBD)) D
64 . I SDTYP(2)=1 S SDTYP(2)="" Q
65 . K SDTYP(2)
66 IF $$EXOE^SDOE(DFN,SDBD,SDED) D
67 . I SDTYP(1)=1 S SDTYP(1)="" Q
68 . K SDTYP(1)
69 I $D(^DPT(DFN,"DE")) D
70 . I SDTYP(4)=1 S SDTYP(4)="",SDACT=0 Q
71 . K SDTYP(4)
72 I $D(^DPT(DFN,"DIS")),$S('SDRANGE:1,+$O(^("DIS",9999999-(SDED+.9)))&($O(^(9999999-(SDED+.9)))<(9999999-(SDBD-.1))):1,1:0) D
73 . I SDTYP(3)=1 S SDTYP(3)="" Q
74 . K SDTYP(3)
75 S SDYN=$$LST^DGMTU(DFN) I SDYN D
76 . I SDTYP(5)=1 S SDTYP(5)="" Q
77 . K SDTYP(5)
78 I SDTYP(7)=1 D
79 . S SDTYP(7)="",GBL="^TMP(""SDPP"","_$J_")" Q
80 . K SDTYP(7)
81 D PRINT^SDPPRT
82 K ^TMP($J,"SDAMA301") S VALMBCK="R"
83 Q
84ENDDT() ;Calculate end date for "all" date
85 N X S X=$O(^DPT(DFN,"S",""),-1) S:X<DT X=DT_.24 Q X
86 ;N X,X1,X2,%H S X1=DT,X2=36600
87 ;D C^%DTC
88 ;Q X_.24
89 ;
90VIEW ; Report # 9 - View Registration Data Report
91 ; Parameters
92 ; ==========
93 ; DFN : Patient Identification Number
94 ;
95 U IO
96 S DFN=$P(PARM,"^",1)
97 D VAL Q:DVBERR
98 D EN1^DGRP
99 Q
100DSRP ; Report # 6 - Reprint a Notice of Discharge Report
101 ; Parameters
102 ; % : 1=Report on all veterans for a given day (BDATE required)
103 ; : 0=Report on a single Veteran (DFN required)
104 ; BDATE : Original Processing Date - $H/FileMan
105 ; DFN : Patient Identification Number
106 ;
107 N %,BDATE,DFN,DFNIEN
108 S %=$P(PARM,"^",1),BDATE=$P(PARM,"^",2),DFN=$P(PARM,"^",3),DFNIEN=""
109 I BDATE="" S DVBERR=1,^TMP("DVBA",$J,1)="0^Incorrect Date" Q
110 D DUZ2^DVBAUTIL
111 U IO
112 D VAL Q:DVBERR
113 I %=1 D Q
114 . S HD="SINGLE NOTICE OF DISCHARGE REPRINTING"
115 . D NOPARM^DVBAUTL2 G:$D(DVBAQUIT) KILL^DVBAUTIL S DTAR=^DVB(396.1,1,0),FDT(0)=$$FMTE^XLFDT(DT,"5DZ")
116 . S HEAD="NOTICE OF DISCHARGE",HEAD1="FOR "_$P(DTAR,U,1)_" ON "_FDT(0)
117 . I $D(^DVB(396.2,"B",DFN)) D
118 . . S DFNIEN=$O(^DVB(396.2,"B",DFN,DFNIEN)),ADM=$P(^DVB(396.2,DFNIEN,0),U,3)
119 . . I $D(^DGPM(+ADM,0)),$P(^(0),U,17)]"" S DCHPTR=$P(^DGPM(+ADM,0),U,17),DISCH=$S($P(^DGPM(DCHPTR,0),U,1)]"":$P(^(0),U,1),1:"") W ?($X+5),"Discharge date: ",$$FMTE^XLFDT(DISCH,"5DZ")
120 . . I $P(^DVB(396.2,DFNIEN,0),U,7)'=DVBAD2 W *7,!!,"This does not belong to your RO.",!! H 3 Q
121 . . I DFNIEN>0 S XDA=DFNIEN,DA=$P(^DVB(396.2,DFNIEN,0),U,1),ADMDT=$P(^DVB(396.2,DFNIEN,0),U,2),MB=$P(^(0),U,3)
122 . . D REPRINT^DVBADSNT
123 D DEQUE^DVBADSRP
124 Q
125 ;
126SPRPT ; Report # 8 - OP(Operation Report)
127 ;Parameters
128 ;=============
129 ; DFN : Patient Identification Number
130 ; SRTN : Select Operation
131 ;
132 N DFN,SRTN,MAGTMPR2,SRSITE
133 I $O(^SRO(133,1))'="B" S SRSITE=1
134 S DFN=$P(PARM,"^",1),SRTN=$P(PARM,"^",2),MAGTMPR2=1
135 D VAL Q:DVBERR
136 D ^SROPRPT
137 Q
138 ;
139CRPON ; Report # - 4 Reprint C&P Final Report
140 ;Parameters
141 ;=============
142 ; RTYPE : Select Reprint Option (D)ate or (V)eteran
143 ; RUNDATE : ORIGINAL PROCESSING date
144 ; ANS : Reprinted by the RO or MAS
145 ; % : LAB 1 OR 0
146 ; DA(1) : Patient IEN for lab results
147 ; DFN : Patient Identification Number
148 ;
149 U IO
150 N ONE
151 S RTYPE=$P(PARM,"^",1),RUNDATE=$P(PARM,"^",2),ANS=$P(PARM,"^",3),%=$P(PARM,"^",4),DA(1)=$P(PARM,"^",5),DFN=$P(PARM,"^",6),DA=DA(1)
152 I RTYPE="V" D VAL Q:DVBERR
153 S XDD=^DD("DD"),$P(ULINE,"_",70)="_",ONE="N",Y=DT
154 X XDD S HD="Reprint C & P Exams",SUPER=0
155 I $D(^XUSEC("DVBA C SUPERVISOR",DUZ)) S SUPER=1
156 S DVBCDT(0)=Y,PGHD="Compensation and Pension Exam Report",LOC=DUZ(2),PG=0,DVBCSITE=$S($D(^DVB(396.1,1,0)):$P(^(0),U,1),1:"Not specified")
157 I "^D^V^"'[RTYPE S DVBERR=1,^TMP("DVBA",$J,1)="0^Incorrect Data Type" Q
158 I ANS="R" K AUTO
159 I ANS="M" S AUTO=1
160 I "^M^R^"'[ANS S DVBERR=1,^TMP("DVBA",$J,1)="0^Incorrect Data Type" Q
161 I RTYPE="D" D GO^DVBCRPRT Q
162 I RTYPE="V" D
163 . S ONE="Y",RO=$P(^DVB(396.3,DA,0),U,3)
164 . I RO'=DUZ(2)&('$D(AUTO))&(SUPER=0) W !!,*7,"Those results do not belong to your office.",!! Q
165 . I RO=DUZ(2)&('$D(AUTO))&("RC"'[($P(^DVB(396.3,DA,0),U,18))) W *7,!!,"This request has not been released to the Regional Office yet.",!! Q
166 . S PRTDATE=$P(^DVB(396.3,DA,0),U,16) I PRTDATE="" W *7,!!,"This has never been printed.",!! I SUPER=0 S OUT=1 Q
167 . I %=1 D REN2^DVBCLABR Q
168 . ;D OV^DVBCRPON
169 . K DVBAON2 D SETLAB^DVBCPRNT,VARS^DVBCUTIL,STEP2^DVBCRPRT
170 Q
171 ;
172CIRPT ; Report # 5 - Insufficient Exam Report
173 ;Parameters
174 ;=============
175 ; RPTTYPE : D/Detailed or S/Summary
176 ; BEGDT : Beginning date $H/FileMan
177 ; ENDDT : Ending date $H/FileMan
178 ; RESANS : Insufficient Reason
179 ;
180 U IO
181 S RPTTYPE=$P(PARM,"^",1),BEGDT=$P(PARM,"^",2),ENDDT=$P(PARM,"^",3),RESANS=$P(PARM,"^",4)
182 I RPTTYPE="S" D SUM^DVBCIRPT Q
183 I RPTTYPE="D" D
184 . I RESANS="" S Y=-1 D INREAS
185 . I '$D(DVBAARY("REASON")) S DVBAQTSL=""
186 . S DVBCYQ=""
187 . I RESANS'="" S Y=RESANS D INREAS
188 . K DTOUT,DUOUT
189 . S Y=-1 D EXMTPE,DETAIL^DVBCIRP1
190 Q
191 ;
192EXMTPE ;
193 N YSAVE,DVBAXIFN
194 S YSAVE=Y
195 F DVBAXIFN=0:0 S DVBAXIFN=$O(^DVB(396.6,DVBAXIFN)) Q:+DVBAXIFN=0 DO
196 . S ^TMP($J,"XMTYPE",DVBAXIFN)=""
197 S Y=-1
198 I +YSAVE>0 S ^TMP($J,"XMTYPE",+YSAVE)=""
199 S Y=YSAVE
200 Q
201INREAS ;
202 N YSAVE,DVBXIFN
203 S YSAVE=Y
204 F DVBAXIFN=0:0 S DVBAXIFN=$O(^DVB(396.94,DVBAXIFN)) Q:+DVBAXIFN=0 DO
205 . S DVBAARY("REASON",DVBAXIFN)=""
206 S Y=-1
207 I +YSAVE>0 S DVBAARY("REASON",+YSAVE)=""
208 S Y=YSAVE
209 Q
210 ;
211CRMS ; Report # 1 - Regional Office 21- day Certificate Printing Report.
212 ; No Parameters
213 ;
214 U IO
215 D ^DVBACRMS
216 Q
217 ;
218CRRR ; Report # 2 - Reprint a 21 - day Certificate for the RO
219 ;Parameters
220 ;=============
221 ; DVBSEL : Select one of the following:
222 ; N Patient Name
223 ; D ORIGINAL PROCESSING DATE
224 ; SDATE : ORIGINAL PROCESSING date - $H/FileMan
225 ; XDA : Patient IEN
226 ;
227 U IO
228 S DVBSEL=$P(PARM,"^",1),SDATE=$P(PARM,"^",2),XDA=$P(PARM,"^",3)
229 I "^D^N^"'[DVBSEL S DVBERR=1,^TMP("DVBA",$J,1)="0^Incorrect Data Type" Q
230 I DVBSEL="D" D I DVBERR Q
231 . I SDATE="" S DVBERR=1,^TMP("DVBA",$J,1)="0^Undefined Date" Q
232 . S %DT="X" S X=SDATE D ^%DT I Y<0 D Q
233 . . S DVBERR=1,^TMP("DVBA",$J,1)="0^Incorrect Date Format"
234 I DVBSEL="N" D I DVBERR Q
235 . I XDA="" S DVBERR=1,^TMP("DVBA",$J,1)="0^Undefined Patient IEN" Q
236 . S DIC=2,DIC(0)="NZX",X=XDA D ^DIC I Y<0 D I DVBERR Q
237 . . S DVBERR=1,^TMP("DVBA",$J,1)="0^Invalid Patient Name."
238 . S DFN=XDA
239 D INIT^DVBACRRR I 'CONT Q
240 D HDR^DVBACRRR,DATA^DVBACRRR
241 Q
242 ;
243CPRNT ; Report # 3 - Print C&P Final Report (manual) Report
244 ; No Parameters
245 ;
246 S XDD=^DD("DD"),$P(ULINE,"_",70)="_",Y=DT
247 X XDD S DVBCDT(0)=Y,PGHD="Compensation and Pension Exam Report",DVBCSITE=$S($D(^DVB(396.1,1,0)):$P(^(0),U,1),1:"Not Specified")
248 D GO^DVBCPRNT
249 Q
250VAL ; VALIDATE PATIENT
251 I $G(DFN)="" S DVBERR=1,^TMP("DVBA",$J,1)="0^Undefined Patient IEN" G END
252 S DIC=2,DIC(0)="NZX",X=DFN D ^DIC
253 I Y<0 S DVBERR=1,^TMP("DVBA",$J,1)="0^Invalid Patient Name." G END
254 Q
255 ;
256HFS() ; -- get hfs file name
257 N H
258 S H=$H
259 Q "DVBA_"_$J_"_"_$P(H,",")_"_"_$P(H,",",2)_".DAT"
260 ;
261HFSOPEN(HANDLE,DVBHFS,DVBMODE) ; Open File
262 S DVBDIRY=$$GET^XPAR("DIV","DVB HFS SCRATCH")
263 ;I DVBDIRY="" S ECERR=1 D Q
264 ;. S ^TMP("DVBA",$J,1)="0^A scratch directory for reports doesn't exist"
265 D OPEN^%ZISH(HANDLE,,DVBHFS,$G(DVBMODE,"W")) D:POP Q:POP
266 .S DVBERR=1,^TMP("DVBA",$J,1)="0^Unable to open file "
267 Q
268 ;
269HFSCLOSE(HANDLE,DVBHFS) ;Close HFS and unload data
270 N DVBDEL,X,%ZIS
271 D CLOSE^%ZISH(HANDLE)
272 S ROOT=$NA(^TMP("DVBA",$J,1)),DVBDEL(DVBHFS)=""
273 K @ROOT
274 S X=$$FTG^%ZISH(,DVBHFS,$NA(@ROOT@(1)),4)
275 S X=$$DEL^%ZISH(,$NA(DVBDEL))
276 Q
Note: See TracBrowser for help on using the repository browser.