source: FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBAHVE3.m@ 1154

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

initial load of FOIAVistA 6/30/08 version

File size: 4.2 KB
Line 
1IBAHVE3 ;WOIFO/SS - CV EXPIRATION REPORT ;06/16/04
2 ;;2.0;INTEGRATED BILLING;**275**;21-MAR-94
3 ;
4START ;start report
5 N Y
6 S Y=+$$CHNGDATE(DT,-90)\1 X ^DD("DD")
7 S DIR(0)="DA^:NOW:EX",DIR("B")=Y,DIR("A")="From DATE: " D ^DIR K DIR I $D(DIRUT) D EXIT Q
8 S IBBEGDT=+Y
9 S DIR(0)="DA^"_+Y_":NOW:EX"
10 S Y=+DT\1 X ^DD("DD")
11 S DIR("B")=Y,DIR("A")="To DATE: " D ^DIR K DIR I $D(DIRUT) D EXIT Q
12 S IBENDDT=+Y
13 D PRNINFO(IBBEGDT,IBENDDT)
14 D OPEN I POP D EXIT Q
15 I $D(IO("Q")) D QUEUED,HOME^%ZIS D END Q
16 U IO
17 D REPORT
18 Q
19 ;
20REPORT ;
21 D PREPRPT
22 D PRINTRPT
23 D END
24 D EXIT
25 Q
26 ;
27END ;
28 I $D(ZTQUEUED) S ZTREQ="@" Q
29 D ^%ZISC
30 D EXIT
31 Q
32 ;
33EXIT ; kills all vars
34 K IBOUT,IBPAGE,POP,IBBEGDT,IBENDDT
35 K IBX,IBXX,Y,DFN,IBCOL2,IBCOL3,IBCOL4,IBCOLPG,IBDONE,^TMP($J,"IBACVEXP"),DIRUT
36 K ZTDESC,ZTQUEUED,ZTREQ,ZTRTN,ZTSAVE,ZTSK,%ZIS,IO("Q")
37 D KVAR^VADPT
38 Q
39 ;
40OPEN ;
41 S %ZIS="QM" D ^%ZIS
42 Q
43 ;
44QUEUED ;
45 S ZTRTN="REPORT^IBAHVE3",ZTDESC="Current Continuous Pt Report",ZTSAVE("IBENDDT")="",ZTSAVE("IBBEGDT")=""
46 D ^%ZTLOAD W !!,$S($D(ZTSK):"Request Queued!",1:"Request Cancelled")
47 Q
48 ;
49PREPRPT ;prepare data
50 ; IBBEGDT - begin date ,IBENDDT - end date
51 S IBCOL2=23,IBCOL3=37,IBCOL4=57,IBCOLPG=70,IBDONE=0
52 N IBDFN,IBDT,IBDFN,IBADMDAT,IB405,IBDISCH,IBCVSTAT,IBEXPDT
53 ;scan all admission before ENDDATE
54 S IBDT=0 F S IBDT=$O(^DGPM("AMV1",IBDT)) Q:+IBDT=0 Q:IBDT>IBENDDT D
55 . S IBDFN=0 F S IBDFN=$O(^DGPM("AMV1",IBDT,IBDFN)) Q:+IBDFN=0 D
56 . . S IB405=0 F S IB405=$O(^DGPM("AMV1",IBDT,IBDFN,IB405)) Q:+IB405=0 D
57 . . . S IBADMDAT=$G(^DGPM(IB405,0)) D:IBADMDAT>0
58 . . . . S IBDISCH=+$G(^DGPM(+$P(IBADMDAT,U,17),0))
59 . . . . ;don't include if discharge before IBBEGDT
60 . . . . I IBDISCH,IBDISCH<IBBEGDT Q
61 . . . . S IBCVSTAT=$$CVEDT^IBACV(IBDFN)
62 . . . . I '$P(IBCVSTAT,U,3) Q ;check if ever had CV
63 . . . . S IBEXPDT=+$P(IBCVSTAT,U,2)
64 . . . . I IBEXPDT=0 Q
65 . . . . I IBEXPDT<IBBEGDT Q ;if expired before IBBEGDT
66 . . . . I IBEXPDT>IBENDDT Q ;if expired after IBENDDT
67 . . . . I IBDISCH,IBEXPDT>IBDISCH Q ;if expired after discharge
68 . . . . I IBEXPDT<IBADMDAT Q ;if expired before admission
69 . . . . D SETTMP(IBDFN,+IBADMDAT,+$P(IBADMDAT,U,6),IBEXPDT)
70 Q
71 ;
72SETTMP(IBDFN,IBADMDT,IBWARD,IBCVDT) ;additional check and set ^TMP
73 ;IBDFN -Pat ID,IBADMDT-admission date
74 ;IBWARD-ward location
75 I '$D(^DPT(IBDFN,0)) Q
76 D
77 . N VADM,VA,VAERR,Y
78 . N DFN,IBPAT,IBSSN,IBADMIS,IBCVEXP
79 . S DFN=+IBDFN
80 . D DEM^VADPT
81 . S IBPAT=$G(VADM(1))
82 . S IBSSN=$P($G(VADM(2)),"^",2)
83 . S Y=IBADMDT\1 X ^DD("DD") S IBADMIS=Y ;date in readable form
84 . S Y=IBCVDT\1 X ^DD("DD") S IBCVEXP=Y ;date in readable form
85 . S ^TMP($J,"IBACVEXP",IBDFN,IBADMDT)=IBPAT_"^"_IBSSN_"^"_IBCVEXP_"^"_IBADMIS
86 Q
87 ;
88PRINTRPT ;print the report
89 S Y=DT X ^DD("DD")
90 S IBPAGE=1,IBOUT=""
91 D HEADER
92 N IBADM,IBDFN,IBTOTAL
93 S IBTOTAL=0
94 S IBDFN=0 F S IBDFN=$O(^TMP($J,"IBACVEXP",IBDFN)) Q:+IBDFN=0!(IBDONE) D
95 . S IBADM=0 F S IBADM=$O(^TMP($J,"IBACVEXP",IBDFN,IBADM)) Q:+IBADM=0!(IBDONE) D
96 . . D PRNTLINE($G(^TMP($J,"IBACVEXP",IBDFN,IBADM))) S IBTOTAL=IBTOTAL+1
97 I 'IBDONE D PRNTLINE("Total: "_IBTOTAL_" patient(s)")
98 Q
99 ;
100HEADER ;print the header
101 I IBPAGE>1,($E(IOST,1,2)="C-") S DIR(0)="E" D ^DIR K DIR I $D(DUOUT) S IBDONE=1 K DUOUT Q
102 I $E(IOST,1,2)["C-"!(IBPAGE>1) W @IOF
103 W !,?8,"***Inpatient Combat Veteran Status Expiration Report***",?IBCOLPG,"PAGE ",IBPAGE
104 W !,?14,"Report from " S Y=IBBEGDT\1 X ^DD("DD") W Y
105 W " to " S Y=IBENDDT\1 X ^DD("DD") W Y
106 W !,?15,"Run Date/Time: " D NOW^%DTC S Y=% X ^DD("DD") W Y
107 W !!,"Patient NAME",?IBCOL2,"SSN",?IBCOL3,"CV exp. date",?IBCOL4,"Date of admission"
108 W !!
109 S IBX="",$P(IBX,"=",IOM)="" W IBX,!
110 S IBPAGE=IBPAGE+1
111 Q
112 ;
113PRNTLINE(IBRECORD) ;print line of the report
114 ;Patient NAME
115 W $E($P(IBRECORD,"^",1),1,21)
116 ;SSN
117 W ?IBCOL2,$E($P(IBRECORD,"^",2),1,11)
118 ;CV exp. date
119 W ?IBCOL3,$E($P(IBRECORD,"^",3),1,14)
120 ;Date of admission
121 W ?IBCOL4,$E($P(IBRECORD,"^",4),1,14)
122 W !
123 D:$Y+4>IOSL HEADER
124 Q
125 ;
126CHNGDATE(DATE,CHNG) ;
127 N X,X1,X2
128 S X1=DATE,X2=CHNG D C^%DTC
129 Q X
130 ;
131 ;
132PRNINFO(IBBEG,IBEND) ;
133 N Y
134 W !,"The following patients whose records indicate that they had CV status, were"
135 W !,"admitted for inpatient care with CV status, and their CV status has expired"
136 W !,"during their stays in the period of "
137 S Y=IBBEG X ^DD("DD")
138 W Y," - "
139 S Y=IBEND X ^DD("DD")
140 W Y
141 Q
142 ;
Note: See TracBrowser for help on using the repository browser.