IBJDI1 ;ALB/CPM - PERCENTAGE OF COMPLETED REGISTRATIONS ;16-DEC-96
;;2.0;INTEGRATED BILLING;**69,98,100,118,128,123,249**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
EN ; - Option entry point.
;
W !!,"This report measures the number of registrations which are being entered"
W !,"without inconsistencies. Please enter a date range representing the dates"
W !,"that patients were first entered into the system.",!
;
DATE D DATE^IBOUTL I IBBDT=""!(IBEDT="") G ENQ
;
; - Sort by division?
S DIR(0)="Y",DIR("B")="NO",DIR("?")="^D DHLP^IBJDI1"
S DIR("A")="Do you wish to sort this report by division" W !
D ^DIR S IBSORT=+Y I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) G ENQ
K DIR,DIROUT,DTOUT,DUOUT,DIRUT
;
I IBSORT D PSDR^IBODIV G:Y<0 ENQ ; Select division(s).
;
; - Select a detailed or summary report.
D DS^IBJD I IBRPT["^" G ENQ
;
I IBRPT="D" W !!,"You will need a 132 column printer for this report!"
E W !!,"This report only requires an 80 column printer."
W !!,"Note: This report requires a search through the entire Patient file."
W !?6,"You should queue this report to run after normal business hours.",!
;
; - Select a device.
S %ZIS="QM" D ^%ZIS G:POP ENQ
I $D(IO("Q")) D G ENQ
.S ZTRTN="DQ^IBJDI1",ZTDESC="IB - COMPLETED REGISTRATIONS"
.F I="IB*","VAUTD","VAUTD(" S ZTSAVE(I)=""
.D ^%ZTLOAD W !!,$S($D(ZTSK):"This job has been queued. The task number is "_ZTSK_".",1:"Unable to queue this job.")
.K ZTSK,IO("Q") D HOME^%ZIS
;
U IO
;
DQ ; - Tasked entry point.
;
I $G(IBXTRACT) D E^IBJDE(1,1) ; Change extract status.
;
N IBQUERY K IB,^TMP("IBJDI1",$J),^TMP("IBDFN",$J),^TMP($J,"SDAMA301")
;
; - Initialize accumulators.
S IBC="COM^DEC^INC^NOTR^NVETC^NVETI^TR^VETC^VETI^TOT",IBQ=0
I IBSORT D
.S I=0 F S I=$S(VAUTD:$O(^DG(40.8,I)),1:$O(VAUTD(I))) Q:'I D
..F J=1:1:10 S IB(I,$P(IBC,U,J))=0
E F I=1:1:10 S IB(0,$P(IBC,U,I))=0
;
; - Find data required for the report.
S DFN=0 F S DFN=$O(^DPT(DFN)) Q:'DFN S IBDN=$G(^(DFN,0)) D Q:IBQ
.I DFN#100=0 S IBQ=$$STOP^IBOUTL("Completed Registrations Report") Q:IBQ
.I $$TESTP(DFN) Q ; Test patient.
.S IBD=+$P(IBDN,U,16) I IBD<IBBDT!(IBD>IBEDT)!('$D(^DPT(DFN,"DIS"))) Q
.D EN^IBJDI11 ; Process patient.
;
I IBQ G ENQ
;
; - Extract summary data.
I $G(IBXTRACT) D E^IBJDE(1,0) G ENQ
;
; - Print the reports.
S IBQ=0 D NOW^%DTC S IBRUN=$$DAT2^IBOUTL(%)
S IBDIV="" F S IBDIV=$O(IB(IBDIV)) Q:IBDIV="" D Q:IBQ
.S IBPAG=0 D:IBRPT="D" DET I 'IBQ D SUM,PAUSE
;
ENQ K ^TMP("IBJDI1",$J),^TMP("IBDFN",$J),^TMP($J,"SDAMA301")
I $D(ZTQUEUED) S ZTREQ="@" G ENQ1
;
D ^%ZISC
ENQ1 K IB,IBC,IBQ,IBBDT,IBEDT,IBRPT,IBD,IBDN,IBIN,IBPAG,IBRUN,IBTOC,IBDOD
K IBDIV,IBREG,IBNEXT,IBX,IBX0,IBX1,IBINPT,IBNOTR,IBNVET,IBPER,IBSORT
K IBFL,VAUTD,DFN,I,J,X,X1,X2,Y,%,%ZIS,POP,ZTDESC,ZTRTN,ZTSAVE
K DIR,DIROUT,DTOUT,DUOUT,DIRUT,IBARRAY,IBCOUNT
Q
;
DET ; - Print the detailed report.
I '$D(^TMP("IBJDI1",$J,IBDIV)) D G DETQ
.D HDET W !!,"There were no registrations with inconsistencies found in this date range."
;
; look up future appts now
S IBARRAY(1)=$$NOW^XLFDT_";9999999"
S IBARRAY(3)="R;I;NT"
S IBARRAY(4)="^TMP(""IBDFN"",$J,"
S IBARRAY("SORT")="P"
S IBARRAY("FLDS")=1
S IBCOUNT=$$SDAPI^SDAMA301(.IBARRAY)
;
S IBX0="" F S IBX0=$O(^TMP("IBJDI1",$J,IBDIV,IBX0)) Q:IBX0="" D Q:IBQ
.D HDET Q:IBQ
.S IBX1="" F S IBX1=$O(^TMP("IBJDI1",$J,IBDIV,IBX0,IBX1)) Q:IBX1="" S IBX=^(IBX1) D Q:IBQ
..I $Y>(IOSL-2) D PAUSE Q:IBQ D HDET Q:IBQ
..;
..; - Print detailed line with primary elig. or inconsistency.
..S IBIN=$P(IBX,U,4),IBFL=0 D DETP(+IBIN)
..;
..; - Print remaining inconsistencies.
..I $P(IBIN,";",2) D
...F I=2:1:$L(IBIN,";") S Y=$P(IBIN,";",I) I Y D Q:IBQ
....I $Y>(IOSL-2) D PAUSE Q:IBQ D HDET,DETP(Y) Q
....W !?70,$E($P($G(^DGIN(38.6,+Y,0)),U),1,20)
;
DETQ I 'IBQ D PAUSE
Q
;
DETP(X) ; - Print detailed line with a primary elig. or inconsistency.
W !,$P(IBX1,"@@"),?27,$P(IBX,U),?39,$P(IBX,U,2),?56,$P(IBX,U,3)
I IBX0,'IBFL W ?70,$E($P($G(^DIC(8,X,0)),U),1,20),"*" S IBFL=1
E W ?70,$E($P($G(^DGIN(38.6,X,0)),U),1,20)
W ?92,$P(IBX,U,5)
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))
W ?114,$$DAT1^IBOUTL(IBNEXT),?124,$P(IBX,U,7)
Q
;
HDET ; - Write the detail report header.
I $E(IOST,1,2)="C-"!(IBPAG) W @IOF,*13
S IBPAG=IBPAG+1
I '$D(^TMP("IBJDI1",$J,IBDIV)) S (IBNVET,IBX0)=""
E S IBNVET=$S(IBX0:"NON-VETERAN",1:"VETERAN")_" "
W !,"Percentage of Completed Registrations",$S(IBDIV:" for "_$P($G(^DG(40.8,IBDIV,0)),U),1:"")
W ?85,"Run Date: ",IBRUN,?123,"Page: ",$J(IBPAG,3)
W !,"Detailed Report of Incomplete ",IBNVET,"Registrations for the Period "_$$DAT1^IBOUTL(IBBDT)_" to "_$$DAT1^IBOUTL(IBEDT)," (*=Had inpat. care, +=Had no treatment)",!!
W:IBX0 ?70,"Primary Eligibility*" W ?116,"Next Date of"
W !,"Patient",?27,"SSN",?39,"Phone Number",?56,"Type of Care"
W ?70,"Inconsistencies",?92,"Registered By",?114,"Appt/Adm Death"
W !,$$DASH(IOM)
S IBQ=$$STOP^IBOUTL("Completed Registrations Report")
Q
;
SUM ; - Print the summary report.
I $E(IOST,1,2)="C-"!(IBPAG) W @IOF,*13
W !!?21,"PERCENTAGE OF COMPLETED REGISTRATIONS",!
I IBDIV D
.S X=$P($G(^DG(40.8,IBDIV,0)),U) W ?(61-$L(X))\2,"SUMMARY REPORT for ",X
E W ?33,"SUMMARY REPORT"
W !!?23,"For the Period ",$$DAT1^IBOUTL(IBBDT)," - ",$$DAT1^IBOUTL(IBEDT)
W !!?24,"Run Date: ",IBRUN,!?8,$$DASH(64)
;
S IBPER(1)=$J($S('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"TR")/IB(IBDIV,"TOT")*100),0,2)
S IBPER(2)=$J($S('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"NOTR")/IB(IBDIV,"TOT")*100),0,2)
S IBPER(3)=$J($S('IB(IBDIV,"TR"):0,1:IB(IBDIV,"COM")/IB(IBDIV,"TR")*100),0,2)
S IBPER(4)=$J($S('IB(IBDIV,"COM"):0,1:IB(IBDIV,"VETC")/IB(IBDIV,"COM")*100),0,2)
S IBPER(5)=$J($S('IB(IBDIV,"COM"):0,1:IB(IBDIV,"NVETC")/IB(IBDIV,"COM")*100),0,2)
S IBPER(6)=$J($S('IB(IBDIV,"TR"):0,1:IB(IBDIV,"INC")/IB(IBDIV,"TR")*100),0,2)
S IBPER(7)=$J($S('IB(IBDIV,"INC"):0,1:IB(IBDIV,"VETI")/IB(IBDIV,"INC")*100),0,2)
S IBPER(8)=$J($S('IB(IBDIV,"INC"):0,1:IB(IBDIV,"NVETI")/IB(IBDIV,"INC")*100),0,2)
S IBPER(9)=$J($S('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"DEC")/IB(IBDIV,"TOT")*100),0,2)
W !?29,"Number of Registrations:",?54,$J(IB(IBDIV,"TOT"),6)
W !?14,"Number of Regs with Treatment Rendered:",?54,$J(IB(IBDIV,"TR"),6),?61,"(",IBPER(1),"%)"
W !?11,"Number of Regs with No Treatment Rendered:",?54,$J(IB(IBDIV,"NOTR"),6),?61,"(",IBPER(2),"%)",!?8,$$DASH(64)
W !?20,"Number of Complete Registrations:",?54,$J(IB(IBDIV,"COM"),6),?61,"(",IBPER(3),"%)"
W !?21,"Number of Complete Veteran Regs:",?54,$J(IB(IBDIV,"VETC"),6),?61,"(",IBPER(4),"%)"
W !?17,"Number of Complete Non-Veteran Regs:",?54,$J(IB(IBDIV,"NVETC"),6),?61,"(",IBPER(5),"%)",!?8,$$DASH(64)
W !?18,"Number of Incomplete Registrations:",?54,$J(IB(IBDIV,"INC"),6),?61,"(",IBPER(6),"%)"
W !?19,"Number of Incomplete Veteran Regs:",?54,$J(IB(IBDIV,"VETI"),6),?61,"(",IBPER(7),"%)"
W !?15,"Number of Incomplete Non-Veteran Regs:",?54,$J(IB(IBDIV,"NVETI"),6),?61,"(",IBPER(8),"%)",!?8,$$DASH(64)
W !?25,"Number of Deceased Patients:",?54,$J(IB(IBDIV,"DEC"),6),?61,"(",IBPER(9),"%)"
Q
;
DASH(X) ; - Return a dashed line.
Q $TR($J("",X)," ","=")
;
PAUSE ; - Page break.
I $E(IOST,1,2)'="C-" Q
N IBX,DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
F IBX=$Y:1:(IOSL-3) W !
S DIR(0)="E" D ^DIR I $D(DIRUT)!($D(DUOUT)) S IBQ=1
Q
;
TESTP(DFN) ; - Check if this is a test patient.
; Input: DFN = Pointer to the patient in file #2
; Output: 1 = Test patient
; 0 = Actual patient
N X
S X=$G(^DPT(DFN,0))
I $P(X,U)="" G TSTPQ
I $P(X,U,9)["00000"!($P(X,U,9)["123456") G TSTPQ
;
S Y=0 Q Y
TSTPQ S Y=1 Q Y
;
SSN(X) ; - Format the SSN.
Q $S(X]"":$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,10),1:"")
;
DHLP ; - 'Sort by division' prompt.
W !!,"Select: '<CR>' to print the trend report without regard to"
W !?15,"division"
W !?11,"'Y' to select those divisions for which a separate"
W !?15,"trend report should be created",!?11,"'^' to quit"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBJDI1 8201 printed Dec 13, 2024@02:23:14 Page 2
IBJDI1 ;ALB/CPM - PERCENTAGE OF COMPLETED REGISTRATIONS ;16-DEC-96
+1 ;;2.0;INTEGRATED BILLING;**69,98,100,118,128,123,249**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
EN ; - Option entry point.
+1 ;
+2 WRITE !!,"This report measures the number of registrations which are being entered"
+3 WRITE !,"without inconsistencies. Please enter a date range representing the dates"
+4 WRITE !,"that patients were first entered into the system.",!
+5 ;
DATE DO DATE^IBOUTL
IF IBBDT=""!(IBEDT="")
GOTO ENQ
+1 ;
+2 ; - Sort by division?
+3 SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("?")="^D DHLP^IBJDI1"
+4 SET DIR("A")="Do you wish to sort this report by division"
WRITE !
+5 DO ^DIR
SET IBSORT=+Y
IF $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
GOTO ENQ
+6 KILL DIR,DIROUT,DTOUT,DUOUT,DIRUT
+7 ;
+8 ; Select division(s).
IF IBSORT
DO PSDR^IBODIV
if Y<0
GOTO ENQ
+9 ;
+10 ; - Select a detailed or summary report.
+11 DO DS^IBJD
IF IBRPT["^"
GOTO ENQ
+12 ;
+13 IF IBRPT="D"
WRITE !!,"You will need a 132 column printer for this report!"
+14 IF '$TEST
WRITE !!,"This report only requires an 80 column printer."
+15 WRITE !!,"Note: This report requires a search through the entire Patient file."
+16 WRITE !?6,"You should queue this report to run after normal business hours.",!
+17 ;
+18 ; - Select a device.
+19 SET %ZIS="QM"
DO ^%ZIS
if POP
GOTO ENQ
+20 IF $DATA(IO("Q"))
Begin DoDot:1
+21 SET ZTRTN="DQ^IBJDI1"
SET ZTDESC="IB - COMPLETED REGISTRATIONS"
+22 FOR I="IB*","VAUTD","VAUTD("
SET ZTSAVE(I)=""
+23 DO ^%ZTLOAD
WRITE !!,$SELECT($DATA(ZTSK):"This job has been queued. The task number is "_ZTSK_".",1:"Unable to queue this job.")
+24 KILL ZTSK,IO("Q")
DO HOME^%ZIS
End DoDot:1
GOTO ENQ
+25 ;
+26 USE IO
+27 ;
DQ ; - Tasked entry point.
+1 ;
+2 ; Change extract status.
IF $GET(IBXTRACT)
DO E^IBJDE(1,1)
+3 ;
+4 NEW IBQUERY
KILL IB,^TMP("IBJDI1",$JOB),^TMP("IBDFN",$JOB),^TMP($JOB,"SDAMA301")
+5 ;
+6 ; - Initialize accumulators.
+7 SET IBC="COM^DEC^INC^NOTR^NVETC^NVETI^TR^VETC^VETI^TOT"
SET IBQ=0
+8 IF IBSORT
Begin DoDot:1
+9 SET I=0
FOR
SET I=$SELECT(VAUTD:$ORDER(^DG(40.8,I)),1:$ORDER(VAUTD(I)))
if 'I
QUIT
Begin DoDot:2
+10 FOR J=1:1:10
SET IB(I,$PIECE(IBC,U,J))=0
End DoDot:2
End DoDot:1
+11 IF '$TEST
FOR I=1:1:10
SET IB(0,$PIECE(IBC,U,I))=0
+12 ;
+13 ; - Find data required for the report.
+14 SET DFN=0
FOR
SET DFN=$ORDER(^DPT(DFN))
if 'DFN
QUIT
SET IBDN=$GET(^(DFN,0))
Begin DoDot:1
+15 IF DFN#100=0
SET IBQ=$$STOP^IBOUTL("Completed Registrations Report")
if IBQ
QUIT
+16 ; Test patient.
IF $$TESTP(DFN)
QUIT
+17 SET IBD=+$PIECE(IBDN,U,16)
IF IBD<IBBDT!(IBD>IBEDT)!('$DATA(^DPT(DFN,"DIS")))
QUIT
+18 ; Process patient.
DO EN^IBJDI11
End DoDot:1
if IBQ
QUIT
+19 ;
+20 IF IBQ
GOTO ENQ
+21 ;
+22 ; - Extract summary data.
+23 IF $GET(IBXTRACT)
DO E^IBJDE(1,0)
GOTO ENQ
+24 ;
+25 ; - Print the reports.
+26 SET IBQ=0
DO NOW^%DTC
SET IBRUN=$$DAT2^IBOUTL(%)
+27 SET IBDIV=""
FOR
SET IBDIV=$ORDER(IB(IBDIV))
if IBDIV=""
QUIT
Begin DoDot:1
+28 SET IBPAG=0
if IBRPT="D"
DO DET
IF 'IBQ
DO SUM
DO PAUSE
End DoDot:1
if IBQ
QUIT
+29 ;
ENQ KILL ^TMP("IBJDI1",$JOB),^TMP("IBDFN",$JOB),^TMP($JOB,"SDAMA301")
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
GOTO ENQ1
+2 ;
+3 DO ^%ZISC
ENQ1 KILL IB,IBC,IBQ,IBBDT,IBEDT,IBRPT,IBD,IBDN,IBIN,IBPAG,IBRUN,IBTOC,IBDOD
+1 KILL IBDIV,IBREG,IBNEXT,IBX,IBX0,IBX1,IBINPT,IBNOTR,IBNVET,IBPER,IBSORT
+2 KILL IBFL,VAUTD,DFN,I,J,X,X1,X2,Y,%,%ZIS,POP,ZTDESC,ZTRTN,ZTSAVE
+3 KILL DIR,DIROUT,DTOUT,DUOUT,DIRUT,IBARRAY,IBCOUNT
+4 QUIT
+5 ;
DET ; - Print the detailed report.
+1 IF '$DATA(^TMP("IBJDI1",$JOB,IBDIV))
Begin DoDot:1
+2 DO HDET
WRITE !!,"There were no registrations with inconsistencies found in this date range."
End DoDot:1
GOTO DETQ
+3 ;
+4 ; look up future appts now
+5 SET IBARRAY(1)=$$NOW^XLFDT_";9999999"
+6 SET IBARRAY(3)="R;I;NT"
+7 SET IBARRAY(4)="^TMP(""IBDFN"",$J,"
+8 SET IBARRAY("SORT")="P"
+9 SET IBARRAY("FLDS")=1
+10 SET IBCOUNT=$$SDAPI^SDAMA301(.IBARRAY)
+11 ;
+12 SET IBX0=""
FOR
SET IBX0=$ORDER(^TMP("IBJDI1",$JOB,IBDIV,IBX0))
if IBX0=""
QUIT
Begin DoDot:1
+13 DO HDET
if IBQ
QUIT
+14 SET IBX1=""
FOR
SET IBX1=$ORDER(^TMP("IBJDI1",$JOB,IBDIV,IBX0,IBX1))
if IBX1=""
QUIT
SET IBX=^(IBX1)
Begin DoDot:2
+15 IF $Y>(IOSL-2)
DO PAUSE
if IBQ
QUIT
DO HDET
if IBQ
QUIT
+16 ;
+17 ; - Print detailed line with primary elig. or inconsistency.
+18 SET IBIN=$PIECE(IBX,U,4)
SET IBFL=0
DO DETP(+IBIN)
+19 ;
+20 ; - Print remaining inconsistencies.
+21 IF $PIECE(IBIN,";",2)
Begin DoDot:3
+22 FOR I=2:1:$LENGTH(IBIN,";")
SET Y=$PIECE(IBIN,";",I)
IF Y
Begin DoDot:4
+23 IF $Y>(IOSL-2)
DO PAUSE
if IBQ
QUIT
DO HDET
DO DETP(Y)
QUIT
+24 WRITE !?70,$EXTRACT($PIECE($GET(^DGIN(38.6,+Y,0)),U),1,20)
End DoDot:4
if IBQ
QUIT
End DoDot:3
End DoDot:2
if IBQ
QUIT
End DoDot:1
if IBQ
QUIT
+25 ;
DETQ IF 'IBQ
DO PAUSE
+1 QUIT
+2 ;
DETP(X) ; - Print detailed line with a primary elig. or inconsistency.
+1 WRITE !,$PIECE(IBX1,"@@"),?27,$PIECE(IBX,U),?39,$PIECE(IBX,U,2),?56,$PIECE(IBX,U,3)
+2 IF IBX0
IF 'IBFL
WRITE ?70,$EXTRACT($PIECE($GET(^DIC(8,X,0)),U),1,20),"*"
SET IBFL=1
+3 IF '$TEST
WRITE ?70,$EXTRACT($PIECE($GET(^DGIN(38.6,X,0)),U),1,20)
+4 WRITE ?92,$PIECE(IBX,U,5)
+5 SET IBNEXT=$ORDER(^TMP($JOB,"SDAMA301",$PIECE(IBX1,"@@",2),0))
SET IBNEXT=$SELECT('IBNEXT:$PIECE(IBX,U,6),'$PIECE(IBX,U,6):IBNEXT,IBNEXT<$PIECE(IBX,U,6):IBNEXT,1:$PIECE(IBX,U,6))
+6 WRITE ?114,$$DAT1^IBOUTL(IBNEXT),?124,$PIECE(IBX,U,7)
+7 QUIT
+8 ;
HDET ; - Write the detail report header.
+1 IF $EXTRACT(IOST,1,2)="C-"!(IBPAG)
WRITE @IOF,*13
+2 SET IBPAG=IBPAG+1
+3 IF '$DATA(^TMP("IBJDI1",$JOB,IBDIV))
SET (IBNVET,IBX0)=""
+4 IF '$TEST
SET IBNVET=$SELECT(IBX0:"NON-VETERAN",1:"VETERAN")_" "
+5 WRITE !,"Percentage of Completed Registrations",$SELECT(IBDIV:" for "_$PIECE($GET(^DG(40.8,IBDIV,0)),U),1:"")
+6 WRITE ?85,"Run Date: ",IBRUN,?123,"Page: ",$JUSTIFY(IBPAG,3)
+7 WRITE !,"Detailed Report of Incomplete ",IBNVET,"Registrations for the Period "_$$DAT1^IBOUTL(IBBDT)_" to "_$$DAT1^IBOUTL(IBEDT)," (*=Had inpat. care, +=Had no treatment)",!!
+8 if IBX0
WRITE ?70,"Primary Eligibility*"
WRITE ?116,"Next Date of"
+9 WRITE !,"Patient",?27,"SSN",?39,"Phone Number",?56,"Type of Care"
+10 WRITE ?70,"Inconsistencies",?92,"Registered By",?114,"Appt/Adm Death"
+11 WRITE !,$$DASH(IOM)
+12 SET IBQ=$$STOP^IBOUTL("Completed Registrations Report")
+13 QUIT
+14 ;
SUM ; - Print the summary report.
+1 IF $EXTRACT(IOST,1,2)="C-"!(IBPAG)
WRITE @IOF,*13
+2 WRITE !!?21,"PERCENTAGE OF COMPLETED REGISTRATIONS",!
+3 IF IBDIV
Begin DoDot:1
+4 SET X=$PIECE($GET(^DG(40.8,IBDIV,0)),U)
WRITE ?(61-$LENGTH(X))\2,"SUMMARY REPORT for ",X
End DoDot:1
+5 IF '$TEST
WRITE ?33,"SUMMARY REPORT"
+6 WRITE !!?23,"For the Period ",$$DAT1^IBOUTL(IBBDT)," - ",$$DAT1^IBOUTL(IBEDT)
+7 WRITE !!?24,"Run Date: ",IBRUN,!?8,$$DASH(64)
+8 ;
+9 SET IBPER(1)=$JUSTIFY($SELECT('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"TR")/IB(IBDIV,"TOT")*100),0,2)
+10 SET IBPER(2)=$JUSTIFY($SELECT('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"NOTR")/IB(IBDIV,"TOT")*100),0,2)
+11 SET IBPER(3)=$JUSTIFY($SELECT('IB(IBDIV,"TR"):0,1:IB(IBDIV,"COM")/IB(IBDIV,"TR")*100),0,2)
+12 SET IBPER(4)=$JUSTIFY($SELECT('IB(IBDIV,"COM"):0,1:IB(IBDIV,"VETC")/IB(IBDIV,"COM")*100),0,2)
+13 SET IBPER(5)=$JUSTIFY($SELECT('IB(IBDIV,"COM"):0,1:IB(IBDIV,"NVETC")/IB(IBDIV,"COM")*100),0,2)
+14 SET IBPER(6)=$JUSTIFY($SELECT('IB(IBDIV,"TR"):0,1:IB(IBDIV,"INC")/IB(IBDIV,"TR")*100),0,2)
+15 SET IBPER(7)=$JUSTIFY($SELECT('IB(IBDIV,"INC"):0,1:IB(IBDIV,"VETI")/IB(IBDIV,"INC")*100),0,2)
+16 SET IBPER(8)=$JUSTIFY($SELECT('IB(IBDIV,"INC"):0,1:IB(IBDIV,"NVETI")/IB(IBDIV,"INC")*100),0,2)
+17 SET IBPER(9)=$JUSTIFY($SELECT('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"DEC")/IB(IBDIV,"TOT")*100),0,2)
+18 WRITE !?29,"Number of Registrations:",?54,$JUSTIFY(IB(IBDIV,"TOT"),6)
+19 WRITE !?14,"Number of Regs with Treatment Rendered:",?54,$JUSTIFY(IB(IBDIV,"TR"),6),?61,"(",IBPER(1),"%)"
+20 WRITE !?11,"Number of Regs with No Treatment Rendered:",?54,$JUSTIFY(IB(IBDIV,"NOTR"),6),?61,"(",IBPER(2),"%)",!?8,$$DASH(64)
+21 WRITE !?20,"Number of Complete Registrations:",?54,$JUSTIFY(IB(IBDIV,"COM"),6),?61,"(",IBPER(3),"%)"
+22 WRITE !?21,"Number of Complete Veteran Regs:",?54,$JUSTIFY(IB(IBDIV,"VETC"),6),?61,"(",IBPER(4),"%)"
+23 WRITE !?17,"Number of Complete Non-Veteran Regs:",?54,$JUSTIFY(IB(IBDIV,"NVETC"),6),?61,"(",IBPER(5),"%)",!?8,$$DASH(64)
+24 WRITE !?18,"Number of Incomplete Registrations:",?54,$JUSTIFY(IB(IBDIV,"INC"),6),?61,"(",IBPER(6),"%)"
+25 WRITE !?19,"Number of Incomplete Veteran Regs:",?54,$JUSTIFY(IB(IBDIV,"VETI"),6),?61,"(",IBPER(7),"%)"
+26 WRITE !?15,"Number of Incomplete Non-Veteran Regs:",?54,$JUSTIFY(IB(IBDIV,"NVETI"),6),?61,"(",IBPER(8),"%)",!?8,$$DASH(64)
+27 WRITE !?25,"Number of Deceased Patients:",?54,$JUSTIFY(IB(IBDIV,"DEC"),6),?61,"(",IBPER(9),"%)"
+28 QUIT
+29 ;
DASH(X) ; - Return a dashed line.
+1 QUIT $TRANSLATE($JUSTIFY("",X)," ","=")
+2 ;
PAUSE ; - Page break.
+1 IF $EXTRACT(IOST,1,2)'="C-"
QUIT
+2 NEW IBX,DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
+3 FOR IBX=$Y:1:(IOSL-3)
WRITE !
+4 SET DIR(0)="E"
DO ^DIR
IF $DATA(DIRUT)!($DATA(DUOUT))
SET IBQ=1
+5 QUIT
+6 ;
TESTP(DFN) ; - Check if this is a test patient.
+1 ; Input: DFN = Pointer to the patient in file #2
+2 ; Output: 1 = Test patient
+3 ; 0 = Actual patient
+4 NEW X
+5 SET X=$GET(^DPT(DFN,0))
+6 IF $PIECE(X,U)=""
GOTO TSTPQ
+7 IF $PIECE(X,U,9)["00000"!($PIECE(X,U,9)["123456")
GOTO TSTPQ
+8 ;
+9 SET Y=0
QUIT Y
TSTPQ SET Y=1
QUIT Y
+1 ;
SSN(X) ; - Format the SSN.
+1 QUIT $SELECT(X]"":$EXTRACT(X,1,3)_"-"_$EXTRACT(X,4,5)_"-"_$EXTRACT(X,6,10),1:"")
+2 ;
DHLP ; - 'Sort by division' prompt.
+1 WRITE !!,"Select: '<CR>' to print the trend report without regard to"
+2 WRITE !?15,"division"
+3 WRITE !?11,"'Y' to select those divisions for which a separate"
+4 WRITE !?15,"trend report should be created",!?11,"'^' to quit"
+5 QUIT
