IBJDIPR ;ALB/HMC - PERCENTAGE OF PATIENTS PREREGISTERED REPORT ;10-MAY-2004
;;2.0;INTEGRATED BILLING;**272,305**;21-MAR-1994
;
EN ; - Option entry point.
;
D ENQ1
W !!,"This report provides number of patients treated, the number of"
W !,"patients pre-registered, % of patients pre-registered, number of"
W !,"patients pre-registered past the pre-registration time frame,"
W !,"number of patients never pre-registered, the clinic exclusions,"
W !,"and the eligibility exclusions.",!!
;
DATE D DATE^IBOUTL I IBBDT=""!(IBEDT="") G ENQ
;
;
TIME ;Pre-Registration time frame, default is 180 days
;
S DIR(0)="N^^I X'>0 K X"
S DIR("A")="Pre-Registration time frame (days)" W !
S DIR("B")=180
S DIR("?")="^D THLP^IBJDIPR"
D ^DIR
S IBPRF=Y
I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) G ENQ
;
K DIR,DIROUT,DTOUT,DUOUT,DIRUT
S DIR(0)="Y",DIR("B")="NO",DIR("?")="^D EHLP^IBJDIPR"
S DIR("A")="Detailed list of Exclusions (Y/N)"
D ^DIR
S IBEXC=+Y
I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) G ENQ
K DIR,DIROUT,DTOUT,DUOUT,DIRUT
;
W !!,"This report only requires an 80 column printer."
W !!,"Note: This report may take a while to run."
W !!,"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^IBJDIPR",ZTDESC="IB - PERCENTAGE OF PATIENTS PREREGISTERED"
.S ZTSAVE("IB*")=""
.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.
;
N IBQUERY,IBQUERY1,DGNAM
K IB,^TMP("IBJDIPR",$J),^TMP("IBJDIPR1",$J)
;
;Temporary global IBJDIPR contains outpatients found for date range in the outpatient encounter file"
;Temporary global IBJDIPR1 contains the clinic exclusions found in the MAS parameter file"
;
S (IBQ,DGPREC,DGPREE)=0
F I="TOT","PRE","PAST","NEVR" S IB(I)=0
;
;Build exclusion temporary file from MAS parameter file,
; ^DG(43 - dbia 4242
;
;Get clinic exclusions and clinic name from ^SC (Hospital location file)
;dbia 401
S X="" F S X=$O(^DG(43,1,"DGPREC","B",X)) Q:X="" D
. S DGNAM=$P($G(^SC(X,0)),U,1) I DGNAM="" Q
. S ^TMP("IBJDIPR1",$J,"DGPREC",X)=""
. S ^TMP("IBJDIPR1",$J,"DGPRECA",DGNAM_U_X)=X ;index sorted by name
. S DGPREC=DGPREC+1
;
;Get eligibility exclusions and eligibility name from ^DIC(8 dbia 427
;
S X="" F S X=$O(^DG(43,1,"DGPREE","B",X)) Q:X="" D
. S DGNAM=$P($G(^DIC(8,X,0)),U,1) I DGNAM="" Q
. S ^TMP("IBJDIPR1",$J,"DGPREE",X)=""
. S ^TMP("IBJDIPR1",$J,"DGPREEA",DGNAM_U_X)=X ;index sorted by name
. S DGPREE=DGPREE+1
;
; - Find outpatients treated within the user-specified date range.
D OUTPT("",IBBDT,IBEDT,"S:IBQ SDSTOP=1 I 'IBQ,$$ENCHK^IBJDI5(Y0) D ENC^IBJDIPR(Y0)","Percentage of Patients Pre-registered",.IBQ,"IBJDIPR",.IBQUERY)
D CLOSE^IBSDU(.IBQUERY),CLOSE^IBSDU(.IBQUERY1) I IBQ G ENQ
;
;Find pre-registered patients
;Use file 41.41 (^DGS), Pre-registration audit file
;dbia 4425
;
S DFN=""
F S DFN=$O(^TMP("IBJDIPR",$J,DFN)) Q:DFN="" D
. S TRDAT=^TMP("IBJDIPR",$J,DFN) ;Get treatment date
. S IB("TOT")=IB("TOT")+1 ;Total unique patients treated
. S PRDAT=TRDAT+.0000001
. S PRDAT=$O(^DGS(41.41,"ADC",DFN,PRDAT),-1) ;Most recent pre-reg date
. I PRDAT="" S IB("NEVR")=IB("NEVR")+1 Q ;never pre-registered
. I PRDAT<$$FMADD^XLFDT(TRDAT,-IBPRF) S IB("PAST")=IB("PAST")+1 Q ;past time frame
. S IB("PRE")=IB("PRE")+1 ;pre-registered
;
; - Print the reports.
; QUIT if this is a electronic transmission to the ARC -IB patch 305
Q:$G(IBARFLAG)
S (IBQ,IBPAG)=0 D NOW^%DTC S IBRUN=$$DAT2^IBOUTL(%)
I 'IBQ D SUM,PAUSE
ENQ K ^TMP("IBJDIPR",$J),^TMP("IBJDIPR1",$J)
I $D(ZTQUEUED) S ZTREQ="@" G ENQ1
;
D ^%ZISC
ENQ1 K IB,IBQ,IBBDT,IBEDT,IBD,IBPAG,IBRUN,IBOED,IBPRF
K DFN,POP,I,X,X1,X2,Y,%,%ZIS,ZTDESC,ZTRTN,ZTSAVE,ZTREQ,ZTQUEUED
K DIR,DIROUT,DTOUT,DUOUT,DIRUT
K DGPREC,DGPREE,PRDAT,TRDAT,IBEXC,DGEE,DGEC,PCENT,TAB,DGNAM
Q
;
OUTPT(DFN,IBBDT,IBEDT,IBCBK,IBMSG,IBQ,IBSUBSCR,IBQUERY,IBDIR) ;
; Input: DFN = IEN of patient if using PATIENT/DATE index, otherwise,
; if null or 0, DATE/TIME index will be used
; IBCBK = The MUMPS code to execute when valid enctr found
; IBBDT/IBEDT = The start/end dates
; IBMSG = The text to send to STOP PROCESSING CALL (if null, no
; call made)
; IBQ = Flag that says whether or not the process was stopped
; by user
; IBQUERY = The # of the QUERY OBJECT to be used to extract outpt
; visits
; IBDIR = Null to look forward, 'B' to look backward thru file
;
N IBVAL,IBFILTER
S IBVAL("BDT")=IBBDT,IBVAL("EDT")=IBEDT_".99" S:$G(DFN) IBVAL("DFN")=DFN
;
; - Look at parent encounters, completely checked out, check user
; requested to quit, process each pt only once if IBSUBSCR'=null
S IBFILTER=""
S IBCBK="I '$P(Y0,U,6),$P(Y0,U,7),$S((Y#100)'=0:1,$G(IBMSG)="""":1,1:'$$STOP^IBJDI21(.IBQ,IBMSG))"_" "_IBCBK
S IBDIR=$S($G(IBDIR)="":"",1:"BACKWARD")
;
;ibsdu will use ^SD(409.1), Standard encounter query, to process
;file 409.68 (^SCE) - dbia402 for outpatient encounter data.
;
D SCAN^IBSDU($S($G(DFN):"PATIENT/DATE",1:"DATE/TIME"),.IBVAL,IBFILTER,IBCBK,0,.IBQUERY,IBDIR) K ^TMP("DIERR",$J)
Q
;
ENC(IBOED) ; - Encounter extract.
; Input: IBOED = Data from outpatient encounter file, ^SCE.
;
S DFN=+$P(IBOED,U,2) I 'DFN Q
;Check exclusions
I $P(IBOED,U,4)]"",$D(^TMP("IBJDIPR1",$J,"DGPREC",$P(IBOED,U,4))) Q ;Clinic exclusion
I $P(IBOED,U,13)]"",$D(^TMP("IBJDIPR1",$J,"DGPREE",$P(IBOED,U,13))) Q ;Eligibility exclusion
D PROC(DFN,IBOED) ; Process patient.
Q
;
PROC(DFN,IBOED) ; - Process each specific patient.
; Input: DFN = Pointer to the patient in file #2
; IBOED = Data from outpatient encounter file, ^SCE.
;
; Pre-set variables IB array, IBBDT, IBEDT are required.
;
I $$TESTP^IBJDI1(DFN) Q ; Test patient.
D ELIG^VADPT G:'VAEL(4) PRCQ ; Patient is not a vet.
;
; - Set patient index
S ^TMP("IBJDIPR",$J,DFN)=$P(IBOED,U,1)
;
PRCQ K VA,VAERR,VAEL
Q
;
SUM ; - Print the summary report.
D HEAD Q:IBQ
W !!?15,"Patients pre-registered from ",$$DAT1^IBOUTL(IBBDT)," - ",$$DAT1^IBOUTL(IBEDT)
W !!?17,"Pre-registration time frame: ",$J(IBPRF,5)," days"
W !!?24,"Run Date: ",IBRUN,!?10,$$DASH(55),!!
;
W ?35,"*Number of Unique Patients Treated: ",$J(IB("TOT"),5)
W !?1,"Unique Outpatients Pre-registered within pre-registration time frame: ",$J(IB("PRE"),5)
S PCENT=0 I IB("TOT") S PCENT=(IB("PRE")/IB("TOT"))*100
W !?47,"Percent Pre-registered: ",$J(PCENT,5,2),"%"
W !!?3,"Unique Outpatients Pre-registered past pre-registration time frame: ",$J(IB("PAST"),5)
W !?30,"Unique Outpatients never Pre-registered: ",$J(IB("NEVR"),5)
W !!?8,"*Counts may not include all patients because of exclusions."
W !!?37,"Number of Eligibility Exclusions: ",$J(DGPREE,5)
W !!?42,"Number of Clinic Exclusions: ",$J(DGPREC,5)
I 'IBEXC Q
I DGPREE D
.S DGEE=1
.D PAUSE Q:IBQ D HEAD Q:IBQ
.S X="" F I=1:1 S X=$O(^TMP("IBJDIPR1",$J,"DGPREEA",X)) Q:X="" D Q:IBQ
..I $Y>(IOSL-4) D PAUSE Q:IBQ D HEAD Q:IBQ
..S TAB=$S((I#2):10,1:45)
..W ?TAB,$E($P(X,U,1),1,30) W:'(I#2) !
I DGPREC D
.S DGEC=1,DGEE=0
.S X="" F I=1:1 S X=$O(^TMP("IBJDIPR1",$J,"DGPRECA",X)) Q:X="" D Q:IBQ
..I I=1 D Q:IBQ
...I ($Y+4)>(IOSL-4) D PAUSE Q:IBQ D HEAD Q
...W !!?10,"Clinic Exclusions",!?9,$$DASH(19),!
..I $Y>(IOSL-4) D PAUSE Q:IBQ D HEAD Q:IBQ
..S TAB=$S((I#2):10,1:45)
..W ?TAB,$E($P(X,U,1),1,30) W:'(I#2) !
Q
;
HEAD ; - Report Header
;
I $E(IOST,1,2)="C-"!(IBPAG) W @IOF,*13
S IBPAG=IBPAG+1
W !?21,"PERCENTAGE OF PATIENTS PRE-REGISTERED",?71,"Page: ",IBPAG
I IBPAG=1 W !!?33,"SUMMARY REPORT" Q
W !!?24,"Run Date: ",IBRUN,!?10,$$DASH(55),!!
W !?10,"Listing of all Exclusions: ",!
I $G(DGEE) W !!?10,"Eligibility Exclusions",!?9,$$DASH(24),!
I $G(DGEC) W !!?10,"Clinic Exclusions",!?9,$$DASH(19),!
S IBQ=$$STOP^IBOUTL("Percentage of Patients Pre-registered")
Q
;
DASH(X) ; - Return a dashed line.
Q $TR($J("",X)," ","=")
;
PAUSE ; - Page break.
I $E(IOST,1,2)'="C-" Q
N DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
S DIR(0)="E" D ^DIR I $D(DIRUT)!($D(DUOUT)) S IBQ=1
Q
;
THLP ; - 'Pre-Registration time frame (days)' prompt
;
W !!,"Number of days to search for pre-registered patients."
W !,"Number of days must be greater that zero."
W !,"Select '<CR>' to accept the default 180 days."
W !?11,"'^' to quit."
Q
;
EHLP ; - 'Detailed list of Exclusions' prompt
;
W !!,"Select '<CR>' to print only the number of eligibility and clinic exclusions."
W !!?11,"'Y' to print list of all eligibility and clinic exclusions."
W !?11,"'^' to quit."
Q
IBAR(IBBDT,IBEDT) ;Entry point for Vista IB AR data to ARC
;patch 305 - called by IBRFN4
N IBPRF,IBEXC,IBARFLAG,IB,IBPERC,IBARDATA
S IBPRF=180,IBEXC=0,IBARFLAG=1
D DQ
I 'IB("TOT") S IBPERC=0 G IBARD
S IBPERC=IB("PRE")/IB("TOT")*100,IBPERC=$FN(IBPERC,"",2)
IBARD S IBARDATA=IB("TOT")_U_IB("PRE")_U_IBPERC_U_IB("PAST")_U_IB("NEVR")
Q IBARDATA
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBJDIPR 9300 printed Oct 16, 2024@18:24:01 Page 2
IBJDIPR ;ALB/HMC - PERCENTAGE OF PATIENTS PREREGISTERED REPORT ;10-MAY-2004
+1 ;;2.0;INTEGRATED BILLING;**272,305**;21-MAR-1994
+2 ;
EN ; - Option entry point.
+1 ;
+2 DO ENQ1
+3 WRITE !!,"This report provides number of patients treated, the number of"
+4 WRITE !,"patients pre-registered, % of patients pre-registered, number of"
+5 WRITE !,"patients pre-registered past the pre-registration time frame,"
+6 WRITE !,"number of patients never pre-registered, the clinic exclusions,"
+7 WRITE !,"and the eligibility exclusions.",!!
+8 ;
DATE DO DATE^IBOUTL
IF IBBDT=""!(IBEDT="")
GOTO ENQ
+1 ;
+2 ;
TIME ;Pre-Registration time frame, default is 180 days
+1 ;
+2 SET DIR(0)="N^^I X'>0 K X"
+3 SET DIR("A")="Pre-Registration time frame (days)"
WRITE !
+4 SET DIR("B")=180
+5 SET DIR("?")="^D THLP^IBJDIPR"
+6 DO ^DIR
+7 SET IBPRF=Y
+8 IF $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
GOTO ENQ
+9 ;
+10 KILL DIR,DIROUT,DTOUT,DUOUT,DIRUT
+11 SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("?")="^D EHLP^IBJDIPR"
+12 SET DIR("A")="Detailed list of Exclusions (Y/N)"
+13 DO ^DIR
+14 SET IBEXC=+Y
+15 IF $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
GOTO ENQ
+16 KILL DIR,DIROUT,DTOUT,DUOUT,DIRUT
+17 ;
+18 WRITE !!,"This report only requires an 80 column printer."
+19 WRITE !!,"Note: This report may take a while to run."
+20 WRITE !!,"You should queue this report to run after normal business hours.",!
+21 ;
+22 ; - Select a device.
+23 SET %ZIS="QM"
DO ^%ZIS
if POP
GOTO ENQ
+24 IF $DATA(IO("Q"))
Begin DoDot:1
+25 SET ZTRTN="DQ^IBJDIPR"
SET ZTDESC="IB - PERCENTAGE OF PATIENTS PREREGISTERED"
+26 SET ZTSAVE("IB*")=""
+27 DO ^%ZTLOAD
+28 WRITE !!,$SELECT($DATA(ZTSK):"This job has been queued. The task number is "_ZTSK_".",1:"Unable to queue this job.")
+29 KILL ZTSK,IO("Q")
DO HOME^%ZIS
End DoDot:1
GOTO ENQ
+30 ;
+31 USE IO
+32 ;
DQ ; - Tasked entry point.
+1 ;
+2 NEW IBQUERY,IBQUERY1,DGNAM
+3 KILL IB,^TMP("IBJDIPR",$JOB),^TMP("IBJDIPR1",$JOB)
+4 ;
+5 ;Temporary global IBJDIPR contains outpatients found for date range in the outpatient encounter file"
+6 ;Temporary global IBJDIPR1 contains the clinic exclusions found in the MAS parameter file"
+7 ;
+8 SET (IBQ,DGPREC,DGPREE)=0
+9 FOR I="TOT","PRE","PAST","NEVR"
SET IB(I)=0
+10 ;
+11 ;Build exclusion temporary file from MAS parameter file,
+12 ; ^DG(43 - dbia 4242
+13 ;
+14 ;Get clinic exclusions and clinic name from ^SC (Hospital location file)
+15 ;dbia 401
+16 SET X=""
FOR
SET X=$ORDER(^DG(43,1,"DGPREC","B",X))
if X=""
QUIT
Begin DoDot:1
+17 SET DGNAM=$PIECE($GET(^SC(X,0)),U,1)
IF DGNAM=""
QUIT
+18 SET ^TMP("IBJDIPR1",$JOB,"DGPREC",X)=""
+19 ;index sorted by name
SET ^TMP("IBJDIPR1",$JOB,"DGPRECA",DGNAM_U_X)=X
+20 SET DGPREC=DGPREC+1
End DoDot:1
+21 ;
+22 ;Get eligibility exclusions and eligibility name from ^DIC(8 dbia 427
+23 ;
+24 SET X=""
FOR
SET X=$ORDER(^DG(43,1,"DGPREE","B",X))
if X=""
QUIT
Begin DoDot:1
+25 SET DGNAM=$PIECE($GET(^DIC(8,X,0)),U,1)
IF DGNAM=""
QUIT
+26 SET ^TMP("IBJDIPR1",$JOB,"DGPREE",X)=""
+27 ;index sorted by name
SET ^TMP("IBJDIPR1",$JOB,"DGPREEA",DGNAM_U_X)=X
+28 SET DGPREE=DGPREE+1
End DoDot:1
+29 ;
+30 ; - Find outpatients treated within the user-specified date range.
+31 DO OUTPT("",IBBDT,IBEDT,"S:IBQ SDSTOP=1 I 'IBQ,$$ENCHK^IBJDI5(Y0) D ENC^IBJDIPR(Y0)","Percentage of Patients Pre-registered",.IBQ,"IBJDIPR",.IBQUERY)
+32 DO CLOSE^IBSDU(.IBQUERY)
DO CLOSE^IBSDU(.IBQUERY1)
IF IBQ
GOTO ENQ
+33 ;
+34 ;Find pre-registered patients
+35 ;Use file 41.41 (^DGS), Pre-registration audit file
+36 ;dbia 4425
+37 ;
+38 SET DFN=""
+39 FOR
SET DFN=$ORDER(^TMP("IBJDIPR",$JOB,DFN))
if DFN=""
QUIT
Begin DoDot:1
+40 ;Get treatment date
SET TRDAT=^TMP("IBJDIPR",$JOB,DFN)
+41 ;Total unique patients treated
SET IB("TOT")=IB("TOT")+1
+42 SET PRDAT=TRDAT+.0000001
+43 ;Most recent pre-reg date
SET PRDAT=$ORDER(^DGS(41.41,"ADC",DFN,PRDAT),-1)
+44 ;never pre-registered
IF PRDAT=""
SET IB("NEVR")=IB("NEVR")+1
QUIT
+45 ;past time frame
IF PRDAT<$$FMADD^XLFDT(TRDAT,-IBPRF)
SET IB("PAST")=IB("PAST")+1
QUIT
+46 ;pre-registered
SET IB("PRE")=IB("PRE")+1
End DoDot:1
+47 ;
+48 ; - Print the reports.
+49 ; QUIT if this is a electronic transmission to the ARC -IB patch 305
+50 if $GET(IBARFLAG)
QUIT
+51 SET (IBQ,IBPAG)=0
DO NOW^%DTC
SET IBRUN=$$DAT2^IBOUTL(%)
+52 IF 'IBQ
DO SUM
DO PAUSE
ENQ KILL ^TMP("IBJDIPR",$JOB),^TMP("IBJDIPR1",$JOB)
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
GOTO ENQ1
+2 ;
+3 DO ^%ZISC
ENQ1 KILL IB,IBQ,IBBDT,IBEDT,IBD,IBPAG,IBRUN,IBOED,IBPRF
+1 KILL DFN,POP,I,X,X1,X2,Y,%,%ZIS,ZTDESC,ZTRTN,ZTSAVE,ZTREQ,ZTQUEUED
+2 KILL DIR,DIROUT,DTOUT,DUOUT,DIRUT
+3 KILL DGPREC,DGPREE,PRDAT,TRDAT,IBEXC,DGEE,DGEC,PCENT,TAB,DGNAM
+4 QUIT
+5 ;
OUTPT(DFN,IBBDT,IBEDT,IBCBK,IBMSG,IBQ,IBSUBSCR,IBQUERY,IBDIR) ;
+1 ; Input: DFN = IEN of patient if using PATIENT/DATE index, otherwise,
+2 ; if null or 0, DATE/TIME index will be used
+3 ; IBCBK = The MUMPS code to execute when valid enctr found
+4 ; IBBDT/IBEDT = The start/end dates
+5 ; IBMSG = The text to send to STOP PROCESSING CALL (if null, no
+6 ; call made)
+7 ; IBQ = Flag that says whether or not the process was stopped
+8 ; by user
+9 ; IBQUERY = The # of the QUERY OBJECT to be used to extract outpt
+10 ; visits
+11 ; IBDIR = Null to look forward, 'B' to look backward thru file
+12 ;
+13 NEW IBVAL,IBFILTER
+14 SET IBVAL("BDT")=IBBDT
SET IBVAL("EDT")=IBEDT_".99"
if $GET(DFN)
SET IBVAL("DFN")=DFN
+15 ;
+16 ; - Look at parent encounters, completely checked out, check user
+17 ; requested to quit, process each pt only once if IBSUBSCR'=null
+18 SET IBFILTER=""
+19 SET IBCBK="I '$P(Y0,U,6),$P(Y0,U,7),$S((Y#100)'=0:1,$G(IBMSG)="""":1,1:'$$STOP^IBJDI21(.IBQ,IBMSG))"_" "_IBCBK
+20 SET IBDIR=$SELECT($GET(IBDIR)="":"",1:"BACKWARD")
+21 ;
+22 ;ibsdu will use ^SD(409.1), Standard encounter query, to process
+23 ;file 409.68 (^SCE) - dbia402 for outpatient encounter data.
+24 ;
+25 DO SCAN^IBSDU($SELECT($GET(DFN):"PATIENT/DATE",1:"DATE/TIME"),.IBVAL,IBFILTER,IBCBK,0,.IBQUERY,IBDIR)
KILL ^TMP("DIERR",$JOB)
+26 QUIT
+27 ;
ENC(IBOED) ; - Encounter extract.
+1 ; Input: IBOED = Data from outpatient encounter file, ^SCE.
+2 ;
+3 SET DFN=+$PIECE(IBOED,U,2)
IF 'DFN
QUIT
+4 ;Check exclusions
+5 ;Clinic exclusion
IF $PIECE(IBOED,U,4)]""
IF $DATA(^TMP("IBJDIPR1",$JOB,"DGPREC",$PIECE(IBOED,U,4)))
QUIT
+6 ;Eligibility exclusion
IF $PIECE(IBOED,U,13)]""
IF $DATA(^TMP("IBJDIPR1",$JOB,"DGPREE",$PIECE(IBOED,U,13)))
QUIT
+7 ; Process patient.
DO PROC(DFN,IBOED)
+8 QUIT
+9 ;
PROC(DFN,IBOED) ; - Process each specific patient.
+1 ; Input: DFN = Pointer to the patient in file #2
+2 ; IBOED = Data from outpatient encounter file, ^SCE.
+3 ;
+4 ; Pre-set variables IB array, IBBDT, IBEDT are required.
+5 ;
+6 ; Test patient.
IF $$TESTP^IBJDI1(DFN)
QUIT
+7 ; Patient is not a vet.
DO ELIG^VADPT
if 'VAEL(4)
GOTO PRCQ
+8 ;
+9 ; - Set patient index
+10 SET ^TMP("IBJDIPR",$JOB,DFN)=$PIECE(IBOED,U,1)
+11 ;
PRCQ KILL VA,VAERR,VAEL
+1 QUIT
+2 ;
SUM ; - Print the summary report.
+1 DO HEAD
if IBQ
QUIT
+2 WRITE !!?15,"Patients pre-registered from ",$$DAT1^IBOUTL(IBBDT)," - ",$$DAT1^IBOUTL(IBEDT)
+3 WRITE !!?17,"Pre-registration time frame: ",$JUSTIFY(IBPRF,5)," days"
+4 WRITE !!?24,"Run Date: ",IBRUN,!?10,$$DASH(55),!!
+5 ;
+6 WRITE ?35,"*Number of Unique Patients Treated: ",$JUSTIFY(IB("TOT"),5)
+7 WRITE !?1,"Unique Outpatients Pre-registered within pre-registration time frame: ",$JUSTIFY(IB("PRE"),5)
+8 SET PCENT=0
IF IB("TOT")
SET PCENT=(IB("PRE")/IB("TOT"))*100
+9 WRITE !?47,"Percent Pre-registered: ",$JUSTIFY(PCENT,5,2),"%"
+10 WRITE !!?3,"Unique Outpatients Pre-registered past pre-registration time frame: ",$JUSTIFY(IB("PAST"),5)
+11 WRITE !?30,"Unique Outpatients never Pre-registered: ",$JUSTIFY(IB("NEVR"),5)
+12 WRITE !!?8,"*Counts may not include all patients because of exclusions."
+13 WRITE !!?37,"Number of Eligibility Exclusions: ",$JUSTIFY(DGPREE,5)
+14 WRITE !!?42,"Number of Clinic Exclusions: ",$JUSTIFY(DGPREC,5)
+15 IF 'IBEXC
QUIT
+16 IF DGPREE
Begin DoDot:1
+17 SET DGEE=1
+18 DO PAUSE
if IBQ
QUIT
DO HEAD
if IBQ
QUIT
+19 SET X=""
FOR I=1:1
SET X=$ORDER(^TMP("IBJDIPR1",$JOB,"DGPREEA",X))
if X=""
QUIT
Begin DoDot:2
+20 IF $Y>(IOSL-4)
DO PAUSE
if IBQ
QUIT
DO HEAD
if IBQ
QUIT
+21 SET TAB=$SELECT((I#2):10,1:45)
+22 WRITE ?TAB,$EXTRACT($PIECE(X,U,1),1,30)
if '(I#2)
WRITE !
End DoDot:2
if IBQ
QUIT
End DoDot:1
+23 IF DGPREC
Begin DoDot:1
+24 SET DGEC=1
SET DGEE=0
+25 SET X=""
FOR I=1:1
SET X=$ORDER(^TMP("IBJDIPR1",$JOB,"DGPRECA",X))
if X=""
QUIT
Begin DoDot:2
+26 IF I=1
Begin DoDot:3
+27 IF ($Y+4)>(IOSL-4)
DO PAUSE
if IBQ
QUIT
DO HEAD
QUIT
+28 WRITE !!?10,"Clinic Exclusions",!?9,$$DASH(19),!
End DoDot:3
if IBQ
QUIT
+29 IF $Y>(IOSL-4)
DO PAUSE
if IBQ
QUIT
DO HEAD
if IBQ
QUIT
+30 SET TAB=$SELECT((I#2):10,1:45)
+31 WRITE ?TAB,$EXTRACT($PIECE(X,U,1),1,30)
if '(I#2)
WRITE !
End DoDot:2
if IBQ
QUIT
End DoDot:1
+32 QUIT
+33 ;
HEAD ; - Report Header
+1 ;
+2 IF $EXTRACT(IOST,1,2)="C-"!(IBPAG)
WRITE @IOF,*13
+3 SET IBPAG=IBPAG+1
+4 WRITE !?21,"PERCENTAGE OF PATIENTS PRE-REGISTERED",?71,"Page: ",IBPAG
+5 IF IBPAG=1
WRITE !!?33,"SUMMARY REPORT"
QUIT
+6 WRITE !!?24,"Run Date: ",IBRUN,!?10,$$DASH(55),!!
+7 WRITE !?10,"Listing of all Exclusions: ",!
+8 IF $GET(DGEE)
WRITE !!?10,"Eligibility Exclusions",!?9,$$DASH(24),!
+9 IF $GET(DGEC)
WRITE !!?10,"Clinic Exclusions",!?9,$$DASH(19),!
+10 SET IBQ=$$STOP^IBOUTL("Percentage of Patients Pre-registered")
+11 QUIT
+12 ;
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 DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
+3 SET DIR(0)="E"
DO ^DIR
IF $DATA(DIRUT)!($DATA(DUOUT))
SET IBQ=1
+4 QUIT
+5 ;
THLP ; - 'Pre-Registration time frame (days)' prompt
+1 ;
+2 WRITE !!,"Number of days to search for pre-registered patients."
+3 WRITE !,"Number of days must be greater that zero."
+4 WRITE !,"Select '<CR>' to accept the default 180 days."
+5 WRITE !?11,"'^' to quit."
+6 QUIT
+7 ;
EHLP ; - 'Detailed list of Exclusions' prompt
+1 ;
+2 WRITE !!,"Select '<CR>' to print only the number of eligibility and clinic exclusions."
+3 WRITE !!?11,"'Y' to print list of all eligibility and clinic exclusions."
+4 WRITE !?11,"'^' to quit."
+5 QUIT
IBAR(IBBDT,IBEDT) ;Entry point for Vista IB AR data to ARC
+1 ;patch 305 - called by IBRFN4
+2 NEW IBPRF,IBEXC,IBARFLAG,IB,IBPERC,IBARDATA
+3 SET IBPRF=180
SET IBEXC=0
SET IBARFLAG=1
+4 DO DQ
+5 IF 'IB("TOT")
SET IBPERC=0
GOTO IBARD
+6 SET IBPERC=IB("PRE")/IB("TOT")*100
SET IBPERC=$FNUMBER(IBPERC,"",2)
IBARD SET IBARDATA=IB("TOT")_U_IB("PRE")_U_IBPERC_U_IB("PAST")_U_IB("NEVR")
+1 QUIT IBARDATA
