source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJDI1.m@ 1608

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

initial load of WorldVistAEHR
File size: 7.8 KB
RevLine 
[613]1IBJDI1 ;ALB/CPM - PERCENTAGE OF COMPLETED REGISTRATIONS ;16-DEC-96
2 ;;2.0;INTEGRATED BILLING;**69,98,100,118,128,123,249**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5EN ; - Option entry point.
6 ;
7 W !!,"This report measures the number of registrations which are being entered"
8 W !,"without inconsistencies. Please enter a date range representing the dates"
9 W !,"that patients were first entered into the system.",!
10 ;
11DATE D DATE^IBOUTL I IBBDT=""!(IBEDT="") G ENQ
12 ;
13 ; - Sort by division?
14 S DIR(0)="Y",DIR("B")="NO",DIR("?")="^D DHLP^IBJDI1"
15 S DIR("A")="Do you wish to sort this report by division" W !
16 D ^DIR S IBSORT=+Y I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) G ENQ
17 K DIR,DIROUT,DTOUT,DUOUT,DIRUT
18 ;
19 I IBSORT D PSDR^IBODIV G:Y<0 ENQ ; Select division(s).
20 ;
21 ; - Select a detailed or summary report.
22 D DS^IBJD I IBRPT["^" G ENQ
23 ;
24 I IBRPT="D" W !!,"You will need a 132 column printer for this report!"
25 E W !!,"This report only requires an 80 column printer."
26 W !!,"Note: This report requires a search through the entire Patient file."
27 W !?6,"You should queue this report to run after normal business hours.",!
28 ;
29 ; - Select a device.
30 S %ZIS="QM" D ^%ZIS G:POP ENQ
31 I $D(IO("Q")) D G ENQ
32 .S ZTRTN="DQ^IBJDI1",ZTDESC="IB - COMPLETED REGISTRATIONS"
33 .F I="IB*","VAUTD","VAUTD(" S ZTSAVE(I)=""
34 .D ^%ZTLOAD 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(1,1) ; Change extract status.
42 ;
43 N IBQUERY K IB,^TMP("IBJDI1",$J),^TMP("IBDFN",$J),^TMP($J,"SDAMA301")
44 ;
45 ; - Initialize accumulators.
46 S IBC="COM^DEC^INC^NOTR^NVETC^NVETI^TR^VETC^VETI^TOT",IBQ=0
47 I IBSORT D
48 .S I=0 F S I=$S(VAUTD:$O(^DG(40.8,I)),1:$O(VAUTD(I))) Q:'I D
49 ..F J=1:1:10 S IB(I,$P(IBC,U,J))=0
50 E F I=1:1:10 S IB(0,$P(IBC,U,I))=0
51 ;
52 ; - Find data required for the report.
53 S DFN=0 F S DFN=$O(^DPT(DFN)) Q:'DFN S IBDN=$G(^(DFN,0)) D Q:IBQ
54 .I DFN#100=0 S IBQ=$$STOP^IBOUTL("Completed Registrations Report") Q:IBQ
55 .I $$TESTP(DFN) Q ; Test patient.
56 .S IBD=+$P(IBDN,U,16) I IBD<IBBDT!(IBD>IBEDT)!('$D(^DPT(DFN,"DIS"))) Q
57 .D EN^IBJDI11 ; Process patient.
58 ;
59 I IBQ G ENQ
60 ;
61 ; - Extract summary data.
62 I $G(IBXTRACT) D E^IBJDE(1,0) G ENQ
63 ;
64 ; - Print the reports.
65 S IBQ=0 D NOW^%DTC S IBRUN=$$DAT2^IBOUTL(%)
66 S IBDIV="" F S IBDIV=$O(IB(IBDIV)) Q:IBDIV="" D Q:IBQ
67 .S IBPAG=0 D:IBRPT="D" DET I 'IBQ D SUM,PAUSE
68 ;
69ENQ K ^TMP("IBJDI1",$J),^TMP("IBDFN",$J),^TMP($J,"SDAMA301")
70 I $D(ZTQUEUED) S ZTREQ="@" G ENQ1
71 ;
72 D ^%ZISC
73ENQ1 K IB,IBC,IBQ,IBBDT,IBEDT,IBRPT,IBD,IBDN,IBIN,IBPAG,IBRUN,IBTOC,IBDOD
74 K IBDIV,IBREG,IBNEXT,IBX,IBX0,IBX1,IBINPT,IBNOTR,IBNVET,IBPER,IBSORT
75 K IBFL,VAUTD,DFN,I,J,X,X1,X2,Y,%,%ZIS,POP,ZTDESC,ZTRTN,ZTSAVE
76 K DIR,DIROUT,DTOUT,DUOUT,DIRUT,IBARRAY,IBCOUNT
77 Q
78 ;
79DET ; - Print the detailed report.
80 I '$D(^TMP("IBJDI1",$J,IBDIV)) D G DETQ
81 .D HDET W !!,"There were no registrations with inconsistencies found in this date range."
82 ;
83 ; look up future appts now
84 S IBARRAY(1)=$$NOW^XLFDT_";9999999"
85 S IBARRAY(3)="R;I;NT"
86 S IBARRAY(4)="^TMP(""IBDFN"",$J,"
87 S IBARRAY("SORT")="P"
88 S IBARRAY("FLDS")=1
89 S IBCOUNT=$$SDAPI^SDAMA301(.IBARRAY)
90 ;
91 S IBX0="" F S IBX0=$O(^TMP("IBJDI1",$J,IBDIV,IBX0)) Q:IBX0="" D Q:IBQ
92 .D HDET Q:IBQ
93 .S IBX1="" F S IBX1=$O(^TMP("IBJDI1",$J,IBDIV,IBX0,IBX1)) Q:IBX1="" S IBX=^(IBX1) D Q:IBQ
94 ..I $Y>(IOSL-2) D PAUSE Q:IBQ D HDET Q:IBQ
95 ..;
96 ..; - Print detailed line with primary elig. or inconsistency.
97 ..S IBIN=$P(IBX,U,4),IBFL=0 D DETP(+IBIN)
98 ..;
99 ..; - Print remaining inconsistencies.
100 ..I $P(IBIN,";",2) D
101 ...F I=2:1:$L(IBIN,";") S Y=$P(IBIN,";",I) I Y D Q:IBQ
102 ....I $Y>(IOSL-2) D PAUSE Q:IBQ D HDET,DETP(Y) Q
103 ....W !?70,$E($P($G(^DGIN(38.6,+Y,0)),U),1,20)
104 ;
105DETQ I 'IBQ D PAUSE
106 Q
107 ;
108DETP(X) ; - Print detailed line with a primary elig. or inconsistency.
109 W !,$P(IBX1,"@@"),?27,$P(IBX,U),?39,$P(IBX,U,2),?56,$P(IBX,U,3)
110 I IBX0,'IBFL W ?70,$E($P($G(^DIC(8,X,0)),U),1,20),"*" S IBFL=1
111 E W ?70,$E($P($G(^DGIN(38.6,X,0)),U),1,20)
112 W ?92,$P(IBX,U,5)
113 S IBNEXT=$O(^TMP($J,"SDAMA301",$P(IBX1,"@@",2),0)),IBNEXT=$S('IBNEXT:$P(IBX,U,6),'$P(IBX,U,6):IBNEXT,IBNEXT<$P(IBX,U,6):IBNEXT,1:$P(IBX,U,6))
114 W ?114,$$DAT1^IBOUTL(IBNEXT),?124,$P(IBX,U,7)
115 Q
116 ;
117HDET ; - Write the detail report header.
118 I $E(IOST,1,2)="C-"!(IBPAG) W @IOF,*13
119 S IBPAG=IBPAG+1
120 I '$D(^TMP("IBJDI1",$J,IBDIV)) S (IBNVET,IBX0)=""
121 E S IBNVET=$S(IBX0:"NON-VETERAN",1:"VETERAN")_" "
122 W !,"Percentage of Completed Registrations",$S(IBDIV:" for "_$P($G(^DG(40.8,IBDIV,0)),U),1:"")
123 W ?85,"Run Date: ",IBRUN,?123,"Page: ",$J(IBPAG,3)
124 W !,"Detailed Report of Incomplete ",IBNVET,"Registrations for the Period "_$$DAT1^IBOUTL(IBBDT)_" to "_$$DAT1^IBOUTL(IBEDT)," (*=Had inpat. care, +=Had no treatment)",!!
125 W:IBX0 ?70,"Primary Eligibility*" W ?116,"Next Date of"
126 W !,"Patient",?27,"SSN",?39,"Phone Number",?56,"Type of Care"
127 W ?70,"Inconsistencies",?92,"Registered By",?114,"Appt/Adm Death"
128 W !,$$DASH(IOM)
129 S IBQ=$$STOP^IBOUTL("Completed Registrations Report")
130 Q
131 ;
132SUM ; - Print the summary report.
133 I $E(IOST,1,2)="C-"!(IBPAG) W @IOF,*13
134 W !!?21,"PERCENTAGE OF COMPLETED REGISTRATIONS",!
135 I IBDIV D
136 .S X=$P($G(^DG(40.8,IBDIV,0)),U) W ?(61-$L(X))\2,"SUMMARY REPORT for ",X
137 E W ?33,"SUMMARY REPORT"
138 W !!?23,"For the Period ",$$DAT1^IBOUTL(IBBDT)," - ",$$DAT1^IBOUTL(IBEDT)
139 W !!?24,"Run Date: ",IBRUN,!?8,$$DASH(64)
140 ;
141 S IBPER(1)=$J($S('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"TR")/IB(IBDIV,"TOT")*100),0,2)
142 S IBPER(2)=$J($S('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"NOTR")/IB(IBDIV,"TOT")*100),0,2)
143 S IBPER(3)=$J($S('IB(IBDIV,"TR"):0,1:IB(IBDIV,"COM")/IB(IBDIV,"TR")*100),0,2)
144 S IBPER(4)=$J($S('IB(IBDIV,"COM"):0,1:IB(IBDIV,"VETC")/IB(IBDIV,"COM")*100),0,2)
145 S IBPER(5)=$J($S('IB(IBDIV,"COM"):0,1:IB(IBDIV,"NVETC")/IB(IBDIV,"COM")*100),0,2)
146 S IBPER(6)=$J($S('IB(IBDIV,"TR"):0,1:IB(IBDIV,"INC")/IB(IBDIV,"TR")*100),0,2)
147 S IBPER(7)=$J($S('IB(IBDIV,"INC"):0,1:IB(IBDIV,"VETI")/IB(IBDIV,"INC")*100),0,2)
148 S IBPER(8)=$J($S('IB(IBDIV,"INC"):0,1:IB(IBDIV,"NVETI")/IB(IBDIV,"INC")*100),0,2)
149 S IBPER(9)=$J($S('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"DEC")/IB(IBDIV,"TOT")*100),0,2)
150 W !?29,"Number of Registrations:",?54,$J(IB(IBDIV,"TOT"),6)
151 W !?14,"Number of Regs with Treatment Rendered:",?54,$J(IB(IBDIV,"TR"),6),?61,"(",IBPER(1),"%)"
152 W !?11,"Number of Regs with No Treatment Rendered:",?54,$J(IB(IBDIV,"NOTR"),6),?61,"(",IBPER(2),"%)",!?8,$$DASH(64)
153 W !?20,"Number of Complete Registrations:",?54,$J(IB(IBDIV,"COM"),6),?61,"(",IBPER(3),"%)"
154 W !?21,"Number of Complete Veteran Regs:",?54,$J(IB(IBDIV,"VETC"),6),?61,"(",IBPER(4),"%)"
155 W !?17,"Number of Complete Non-Veteran Regs:",?54,$J(IB(IBDIV,"NVETC"),6),?61,"(",IBPER(5),"%)",!?8,$$DASH(64)
156 W !?18,"Number of Incomplete Registrations:",?54,$J(IB(IBDIV,"INC"),6),?61,"(",IBPER(6),"%)"
157 W !?19,"Number of Incomplete Veteran Regs:",?54,$J(IB(IBDIV,"VETI"),6),?61,"(",IBPER(7),"%)"
158 W !?15,"Number of Incomplete Non-Veteran Regs:",?54,$J(IB(IBDIV,"NVETI"),6),?61,"(",IBPER(8),"%)",!?8,$$DASH(64)
159 W !?25,"Number of Deceased Patients:",?54,$J(IB(IBDIV,"DEC"),6),?61,"(",IBPER(9),"%)"
160 Q
161 ;
162DASH(X) ; - Return a dashed line.
163 Q $TR($J("",X)," ","=")
164 ;
165PAUSE ; - Page break.
166 I $E(IOST,1,2)'="C-" Q
167 N IBX,DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
168 F IBX=$Y:1:(IOSL-3) W !
169 S DIR(0)="E" D ^DIR I $D(DIRUT)!($D(DUOUT)) S IBQ=1
170 Q
171 ;
172TESTP(DFN) ; - Check if this is a test patient.
173 ; Input: DFN = Pointer to the patient in file #2
174 ; Output: 1 = Test patient
175 ; 0 = Actual patient
176 N X
177 S X=$G(^DPT(DFN,0))
178 I $P(X,U)="" G TSTPQ
179 I $P(X,U,9)["00000"!($P(X,U,9)["123456") G TSTPQ
180 ;
181 S Y=0 Q Y
182TSTPQ S Y=1 Q Y
183 ;
184SSN(X) ; - Format the SSN.
185 Q $S(X]"":$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,10),1:"")
186 ;
187DHLP ; - 'Sort by division' prompt.
188 W !!,"Select: '<CR>' to print the trend report without regard to"
189 W !?15,"division"
190 W !?11,"'Y' to select those divisions for which a separate"
191 W !?15,"trend report should be created",!?11,"'^' to quit"
192 Q
Note: See TracBrowser for help on using the repository browser.