| 1 | IBJDI1 ;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 | ;
|
---|
| 5 | EN ; - 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 | ;
|
---|
| 11 | DATE 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 | ;
|
---|
| 39 | DQ ; - 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 | ;
|
---|
| 69 | ENQ K ^TMP("IBJDI1",$J),^TMP("IBDFN",$J),^TMP($J,"SDAMA301")
|
---|
| 70 | I $D(ZTQUEUED) S ZTREQ="@" G ENQ1
|
---|
| 71 | ;
|
---|
| 72 | D ^%ZISC
|
---|
| 73 | ENQ1 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 | ;
|
---|
| 79 | DET ; - 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 | ;
|
---|
| 105 | DETQ I 'IBQ D PAUSE
|
---|
| 106 | Q
|
---|
| 107 | ;
|
---|
| 108 | DETP(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 | ;
|
---|
| 117 | HDET ; - 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 | ;
|
---|
| 132 | SUM ; - 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 | ;
|
---|
| 162 | DASH(X) ; - Return a dashed line.
|
---|
| 163 | Q $TR($J("",X)," ","=")
|
---|
| 164 | ;
|
---|
| 165 | PAUSE ; - 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 | ;
|
---|
| 172 | TESTP(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
|
---|
| 182 | TSTPQ S Y=1 Q Y
|
---|
| 183 | ;
|
---|
| 184 | SSN(X) ; - Format the SSN.
|
---|
| 185 | Q $S(X]"":$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,10),1:"")
|
---|
| 186 | ;
|
---|
| 187 | DHLP ; - '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
|
---|