- 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 Jan 18, 2025@03:24:25 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