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