Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBJDIPR

IBJDIPR.m

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