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

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

initial load of FOIAVistA 6/30/08 version

File size: 8.0 KB
Line 
1IBJDI3 ;ALB/CPM - NO EMPLOYER LISTING ; 17-DEC-96
2 ;;2.0;INTEGRATED BILLING;**69,91,98,100,118,123**;21-MAR-94
3 ;
4EN ; - Option entry point.
5 ;
6 W !!,"This report provides a measure of the number of veteran patients who"
7 W !,"have been identified as being employed, but have no employer on file.",!
8 ;
9DATE D DATE^IBOUTL I IBBDT=""!(IBEDT="") G ENQ
10 ;
11 ; - Sort by division?
12 S DIR(0)="Y",DIR("B")="NO",DIR("?")="^D DHLP^IBJDI3"
13 S DIR("A")="Do you wish to sort this report by division" W !
14 D ^DIR S IBSORT=+Y I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) G ENQ
15 K DIR,DIROUT,DTOUT,DUOUT,DIRUT
16 ;
17 I IBSORT D PSDR^IBODIV G:Y<0 ENQ ; Select division(s).
18 ;
19 ; - Select a detailed or summary report.
20 D DS^IBJD I IBRPT["^" G ENQ
21 ;
22 I IBRPT="D" W !!,"You will need a 132 column printer for this report!"
23 E W !!,"This report only requires an 80 column printer."
24 ;
25 W !!,"Note: This report may take a while to run."
26 W !?6,"You should queue this report to run after normal business hours.",!
27 ;
28 ; - Select a device.
29 S %ZIS="QM" D ^%ZIS G:POP ENQ
30 I $D(IO("Q")) D G ENQ
31 .S ZTRTN="DQ^IBJDI3",ZTDESC="IB - NO EMPLOYER LISTING"
32 .F I="IB*","VAUTD","VAUTD(" S ZTSAVE(I)=""
33 .D ^%ZTLOAD
34 .W !!,$S($D(ZTSK):"This job has been queued. The task number is "_ZTSK_".",1:"Unable to queue this job.")
35 .K ZTSK,IO("Q") D HOME^%ZIS
36 ;
37 U IO
38 ;
39DQ ; - Tasked entry point.
40 ;
41 I $G(IBXTRACT) D E^IBJDE(3,1) ; Change extract status.
42 ;
43 N IBQUERY,IBQUERY1
44 K IB,^TMP("IBJDI31",$J),^TMP("IBJDI32",$J)
45 S IBC="DEC^NO^OK^TOT",IBQ=0
46 I IBSORT D G INP
47 .S I=0 F S I=$S(VAUTD:$O(^DG(40.8,I)),1:$O(VAUTD(I))) Q:'I D
48 ..S J=$P($G(^DG(40.8,I,0)),U) F K=1:1:4 S IB(J,$P(IBC,U,K))=0
49 S IBDIV="ALL" F I=1:1:4 S IB("ALL",$P(IBC,U,I))=0
50 ;
51INP ; - Find inpatients treated within the user-specified date range.
52 S IBD=IBBDT-.01 F S IBD=$O(^DGPM("ATT3",IBD)) Q:'IBD!(IBD\1>IBEDT) D Q:IBQ
53 .S IBPM=0 F S IBPM=$O(^DGPM("ATT3",IBD,IBPM)) Q:'IBPM D Q:IBQ
54 ..I IBPM#100=0 S IBQ=$$STOP^IBOUTL("No Employer Listing") Q:IBQ
55 ..S IBPMD=$G(^DGPM(IBPM,0)) Q:'IBPMD S DFN=+$P(IBPMD,U,3) Q:'DFN
56 ..I IBSORT S IBDIV=$$DIV^IBJDI21(1,+$P(IBPMD,U,6)) Q:'$D(IB(IBDIV))
57 ..;
58 ..; - Process patient.
59 ..I '$D(^TMP("IBJDI31",$J,DFN)) D PROC(DFN,"*",.IBQUERY)
60 ;
61 D CLOSE^IBSDU(.IBQUERY) I IBQ G ENQ
62 ;
63 ; - Find outpatients treated within the user-specified date range.
64 D OUTPT^IBJDI21("",IBBDT,IBEDT,"S:IBQ SDSTOP=1 I 'IBQ,$$ENCHK^IBJDI5(Y0) D ENC^IBJDI3(Y0,.IBQUERY1)","No Employer Listing",.IBQ,"IBJDI31",.IBQUERY)
65 D CLOSE^IBSDU(.IBQUERY),CLOSE^IBSDU(.IBQUERY1) I IBQ G ENQ
66 ;
67 ; - Extract summary data.
68 I $G(IBXTRACT) D G ENQ
69 .F X="DEC","NO","OK","TOT" S IB(X)=$G(IB("ALL",X))
70 .D E^IBJDE(3,0)
71 ;
72 ; - Print the reports.
73 S (IBQ,IBPAG)=0 D NOW^%DTC S IBRUN=$$DAT2^IBOUTL(%)
74 S IBDIV="" F S IBDIV=$O(IB(IBDIV)) Q:IBDIV="" D Q:IBQ
75 . D:IBRPT="D" DET I 'IBQ D SUM,PAUSE
76 ;
77ENQ K ^TMP("IBJDI31",$J),^TMP("IBJDI32",$J)
78 I $D(ZTQUEUED) S ZTREQ="@" G ENQ1
79 ;
80 D ^%ZISC
81ENQ1 K IB,IBQ,IBBDT,IBEDT,IBRPT,IBC,IBD,IBDN,IBPAG,IBRUN,IBX,IBPER,IBEMP
82 K IBDIV,IBDOD,IBSORT,IBLT,IBDT,IBES,IBDTF,IBPAT,IBXX,IBOE,IBOED,IBPM,IBPMD
83 K VAUTD,DFN,POP,I,J,K,X,X1,X2,Y,%,%ZIS,ZTDESC,ZTRTN,ZTSAVE
84 K DIR,DIROUT,DTOUT,DUOUT,DIRUT
85 Q
86 ;
87ENC(IBOED,IBQUERY1) ; - Encounter extract.
88 ; IBQUERY1 = the # of the QUERY to use to do the extract.
89 ; Pre-set variables IB array, IBSORT also required.
90 ;
91 S DFN=+$P(IBOED,U,2) I 'DFN Q
92 I IBSORT S IBDIV=$$DIV^IBJDI21(0,+$P(IBOED,U,11)) Q:'$D(IB(IBDIV))
93 D PROC(DFN,"",.IBQUERY1) ; Process patient.
94 Q
95 ;
96PROC(DFN,IBIPC,IBQUERY) ; - Process each specific patient.
97 ; Input: DFN = Pointer to the patient in file #2
98 ; IBIPC = Inpatient treatment marker
99 ; ("*"=Had inpat. treatment, null=No inpat. treatment)
100 ; IBQUERY = The # of the QUERY OBJECT to be used to extract
101 ; outpatient visits. Be sure to close the query object
102 ; when done
103 ;
104 ; Pre-set variables IB array, IBBDT, IBEDT, IBDIV, IBSORT are required.
105 ;
106 I $$TESTP^IBJDI1(DFN) Q ; Test patient.
107 D ELIG^VADPT G:'VAEL(4) PRCQ ; Patient is not a vet.
108 ;
109 ; - Check if patient is deceased; get date of death.
110 S IBDOD=$S(+$G(^DPT(DFN,.35)):^(.35)\1,1:"")
111 I IBDOD S IB(IBDIV,"DEC")=IB(IBDIV,"DEC")+1
112 ;
113 ; - Set patient index and 'total patients' accumulator.
114 S ^TMP("IBJDI31",$J,DFN)="",IB(IBDIV,"TOT")=IB(IBDIV,"TOT")+1
115 ;
116 S IBDN=$G(^DPT(DFN,0)),IBEMP=$G(^(.311)),IBES=$P(IBEMP,U,15)
117 ;
118 ; - Empl. status is null/unknown, employed (full/part), or retired
119 ; AND no employer is specified.
120 I $P(IBEMP,U)="",(IBES=""!("^1^2^5^9^"[("^"_IBES_"^"))) D G PRCQ
121 .S IB(IBDIV,"NO")=IB(IBDIV,"NO")+1 I IBRPT="D" D SET(.IBQUERY)
122 S IB(IBDIV,"OK")=IB(IBDIV,"OK")+1
123 ;
124PRCQ K VA,VAERR,VAEL
125 Q
126 ;
127SET(IBQUERY) ; - Set up detailed information for pts to appear on the report.
128 ; Input: IBQUERY = The # of the QUERY OBJECT to be used to extract
129 ; outpatient visits
130 ;
131 ; Pre-set variable IBDIV is reqiured.
132 ;
133 ; - Find last treatment date (LTD).
134 S (IBDT,IBLT)=0 F S IBDT=$O(^DGPM("ATID3",DFN,IBDT)) Q:+IBDT=0 D
135 .S IBDTF=9999999.9999999-IBDT\1
136 .S:IBDTF>IBLT IBLT=IBDTF Q:IBDTF<IBBDT!(IBDTF>IBEDT)
137 ;
138 ; - Look through outpatient encounters.
139 D OUTPT^IBJDI21(DFN,IBBDT,IBEDT,"S IBOED=Y0,IBDT=+IBOED,IBDTF=IBDT\1 S:IBDTF>IBLT IBLT=IBDTF","","","",.IBQUERY)
140 ;
141 ; - If current inpatient, set LTD to today.
142 I $G(^DPT(DFN,.105)) S IBLT=DT
143 ;
144SETC S ^TMP("IBJDI32",$J,IBDIV,$P(IBDN,U)_IBIPC_"@@"_DFN)=$P(IBDN,U,9)_U_IBES_U_IBLT_U_IBDOD
145 Q
146 ;
147DIV(X) ; - Return division name.
148 Q $P($G(^DG(40.8,X,0)),U)
149 ;
150DET ; - Print the detailed report.
151 D HDET Q:IBQ
152 I '$D(^TMP("IBJDI32",$J,IBDIV)) W !!,"There were no patients treated in this date range missing an employer." G DETQ
153 ;
154 S IBXX="" F S IBXX=$O(^TMP("IBJDI32",$J,IBDIV,IBXX)) Q:IBXX="" S IBX=^(IBXX) D Q:IBQ
155 .I $Y>(IOSL-4) D PAUSE Q:IBQ D HDET Q:IBQ
156 .W !,$P(IBXX,"@@"),?34,$$SSN($P(IBX,U))
157 .S X=$$EXPAND^IBJD(2,.31115,$P(IBX,U,2)) W ?50,$S(X="":"UNANSWERED",1:X)
158 .W ?72,$$DAT2^IBOUTL($P(IBX,U,3)),?90,$$DAT2^IBOUTL($P(IBX,U,4))
159 ;
160DETQ I 'IBQ D PAUSE
161 Q
162 ;
163HDET ; - Write the detail report header.
164 I $E(IOST,1,2)="C-"!(IBPAG) W @IOF,*13
165 S IBPAG=IBPAG+1
166 W "No Employer Listing",$S(IBDIV'="ALL":" for "_IBDIV,1:""),?80,"Run Date: ",IBRUN,?123,"Page: ",IBPAG
167 W !,"Patients without an employer treated in the period ",$$DAT1^IBOUTL(IBBDT)," to ",$$DAT1^IBOUTL(IBEDT)," ('*' = Had inpatient care)"
168 W !,"Patient",?34,"SSN",?50,"Employment Status",?72,"Last Trmt Date",?90,"Date of Death"
169 W !,$$DASH(132),!
170 S IBQ=$$STOP^IBOUTL("No Employer Listing")
171 Q
172 ;
173SUM ; - Print the summary report.
174 I $E(IOST,1,2)="C-"!(IBPAG) W @IOF,*13
175 S IBPAG=IBPAG+1
176 W !!?30,"NO EMPLOYER LISTING",?71,"Page: ",IBPAG,!
177 I IBDIV'="ALL" W ?(61-$L(IBDIV))\2,"SUMMARY REPORT for ",IBDIV
178 E W ?33,"SUMMARY REPORT"
179 W !!?19,"Patients treated from ",$$DAT1^IBOUTL(IBBDT)," - ",$$DAT1^IBOUTL(IBEDT)
180 W !!?24,"Run Date: ",IBRUN,!?17,$$DASH(45),!!
181 ;
182 S IBPER=$J($S('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"NO")/IB(IBDIV,"TOT")*100),0,2)
183 W ?24,"Number of Patients Treated:",?53,$J(IB(IBDIV,"TOT"),5)
184 W !?23,"Number of Deceased Patients:",?53,$J(IB(IBDIV,"DEC"),5),?62,"(",$J($S('IB(IBDIV,"DEC"):0,1:IB(IBDIV,"DEC")/IB(IBDIV,"TOT")*100),0,2),"%)"
185 W !?3,"Number of Patients Employed without an Employer:",?53,$J(IB(IBDIV,"NO"),5),$S(IB(IBDIV,"NO"):"*",1:""),?62,"(",IBPER,"%)"
186 W !," Number of Patients Unemployed or with an Employer:",?53,$J(IB(IBDIV,"OK"),5),?62,"(",$J($S('IBPER:0,1:100-IBPER),0,2),"%)"
187 I IB(IBDIV,"NO") D
188 .W !!!!!?2,"*This is the total number of veterans who have no employer on file, but"
189 .W !,?3,"have an employment status of Full-Time, Part-Time, Retired, Unknown or",!?3,"null."
190 Q
191 ;
192DASH(X) ; - Return a dashed line.
193 Q $TR($J("",X)," ","=")
194 ;
195PAUSE ; - Page break.
196 I $E(IOST,1,2)'="C-" Q
197 N IBX,DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
198 F IBX=$Y:1:(IOSL-3) W !
199 S DIR(0)="E" D ^DIR I $D(DIRUT)!($D(DUOUT)) S IBQ=1
200 Q
201 ;
202SSN(X) ; - Format the SSN.
203 Q $S(X]"":$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,10),1:"")
204 ;
205DHLP ; - 'Sort by division' prompt.
206 W !!,"Select: '<CR>' to print the trend report without regard to"
207 W !?15,"division"
208 W !?11,"'Y' to select those divisions for which a separate"
209 W !?15,"trend report should be created",!?11,"'^' to quit"
210 Q
Note: See TracBrowser for help on using the repository browser.