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

IBJDI3.m

Go to the documentation of this file.
  1. IBJDI3 ;ALB/CPM - NO EMPLOYER LISTING ; 17-DEC-96
  1. ;;2.0;INTEGRATED BILLING;**69,91,98,100,118,123**;21-MAR-94
  1. ;
  1. EN ; - Option entry point.
  1. ;
  1. W !!,"This report provides a measure of the number of veteran patients who"
  1. W !,"have been identified as being employed, but have no employer on file.",!
  1. ;
  1. DATE D DATE^IBOUTL I IBBDT=""!(IBEDT="") G ENQ
  1. ;
  1. ; - Sort by division?
  1. S DIR(0)="Y",DIR("B")="NO",DIR("?")="^D DHLP^IBJDI3"
  1. S DIR("A")="Do you wish to sort this report by division" W !
  1. D ^DIR S IBSORT=+Y I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) G ENQ
  1. K DIR,DIROUT,DTOUT,DUOUT,DIRUT
  1. ;
  1. I IBSORT D PSDR^IBODIV G:Y<0 ENQ ; Select division(s).
  1. ;
  1. ; - Select a detailed or summary report.
  1. D DS^IBJD I IBRPT["^" G ENQ
  1. ;
  1. I IBRPT="D" W !!,"You will need a 132 column printer for this report!"
  1. E W !!,"This report only requires an 80 column printer."
  1. ;
  1. W !!,"Note: This report may take a while to run."
  1. W !?6,"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^IBJDI3",ZTDESC="IB - NO EMPLOYER LISTING"
  1. .F I="IB*","VAUTD","VAUTD(" S ZTSAVE(I)=""
  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. I $G(IBXTRACT) D E^IBJDE(3,1) ; Change extract status.
  1. ;
  1. N IBQUERY,IBQUERY1
  1. K IB,^TMP("IBJDI31",$J),^TMP("IBJDI32",$J)
  1. S IBC="DEC^NO^OK^TOT",IBQ=0
  1. I IBSORT D G INP
  1. .S I=0 F S I=$S(VAUTD:$O(^DG(40.8,I)),1:$O(VAUTD(I))) Q:'I D
  1. ..S J=$P($G(^DG(40.8,I,0)),U) F K=1:1:4 S IB(J,$P(IBC,U,K))=0
  1. S IBDIV="ALL" F I=1:1:4 S IB("ALL",$P(IBC,U,I))=0
  1. ;
  1. INP ; - Find inpatients treated within the user-specified date range.
  1. S IBD=IBBDT-.01 F S IBD=$O(^DGPM("ATT3",IBD)) Q:'IBD!(IBD\1>IBEDT) D Q:IBQ
  1. .S IBPM=0 F S IBPM=$O(^DGPM("ATT3",IBD,IBPM)) Q:'IBPM D Q:IBQ
  1. ..I IBPM#100=0 S IBQ=$$STOP^IBOUTL("No Employer Listing") Q:IBQ
  1. ..S IBPMD=$G(^DGPM(IBPM,0)) Q:'IBPMD S DFN=+$P(IBPMD,U,3) Q:'DFN
  1. ..I IBSORT S IBDIV=$$DIV^IBJDI21(1,+$P(IBPMD,U,6)) Q:'$D(IB(IBDIV))
  1. ..;
  1. ..; - Process patient.
  1. ..I '$D(^TMP("IBJDI31",$J,DFN)) D PROC(DFN,"*",.IBQUERY)
  1. ;
  1. D CLOSE^IBSDU(.IBQUERY) I IBQ G ENQ
  1. ;
  1. ; - Find outpatients treated within the user-specified date range.
  1. D OUTPT^IBJDI21("",IBBDT,IBEDT,"S:IBQ SDSTOP=1 I 'IBQ,$$ENCHK^IBJDI5(Y0) D ENC^IBJDI3(Y0,.IBQUERY1)","No Employer Listing",.IBQ,"IBJDI31",.IBQUERY)
  1. D CLOSE^IBSDU(.IBQUERY),CLOSE^IBSDU(.IBQUERY1) I IBQ G ENQ
  1. ;
  1. ; - Extract summary data.
  1. I $G(IBXTRACT) D G ENQ
  1. .F X="DEC","NO","OK","TOT" S IB(X)=$G(IB("ALL",X))
  1. .D E^IBJDE(3,0)
  1. ;
  1. ; - Print the reports.
  1. S (IBQ,IBPAG)=0 D NOW^%DTC S IBRUN=$$DAT2^IBOUTL(%)
  1. S IBDIV="" F S IBDIV=$O(IB(IBDIV)) Q:IBDIV="" D Q:IBQ
  1. . D:IBRPT="D" DET I 'IBQ D SUM,PAUSE
  1. ;
  1. ENQ K ^TMP("IBJDI31",$J),^TMP("IBJDI32",$J)
  1. I $D(ZTQUEUED) S ZTREQ="@" G ENQ1
  1. ;
  1. D ^%ZISC
  1. ENQ1 K IB,IBQ,IBBDT,IBEDT,IBRPT,IBC,IBD,IBDN,IBPAG,IBRUN,IBX,IBPER,IBEMP
  1. K IBDIV,IBDOD,IBSORT,IBLT,IBDT,IBES,IBDTF,IBPAT,IBXX,IBOE,IBOED,IBPM,IBPMD
  1. K VAUTD,DFN,POP,I,J,K,X,X1,X2,Y,%,%ZIS,ZTDESC,ZTRTN,ZTSAVE
  1. K DIR,DIROUT,DTOUT,DUOUT,DIRUT
  1. Q
  1. ;
  1. ENC(IBOED,IBQUERY1) ; - Encounter extract.
  1. ; IBQUERY1 = the # of the QUERY to use to do the extract.
  1. ; Pre-set variables IB array, IBSORT also required.
  1. ;
  1. S DFN=+$P(IBOED,U,2) I 'DFN Q
  1. I IBSORT S IBDIV=$$DIV^IBJDI21(0,+$P(IBOED,U,11)) Q:'$D(IB(IBDIV))
  1. D PROC(DFN,"",.IBQUERY1) ; Process patient.
  1. Q
  1. ;
  1. PROC(DFN,IBIPC,IBQUERY) ; - Process each specific patient.
  1. ; Input: DFN = Pointer to the patient in file #2
  1. ; IBIPC = Inpatient treatment marker
  1. ; ("*"=Had inpat. treatment, null=No inpat. treatment)
  1. ; IBQUERY = The # of the QUERY OBJECT to be used to extract
  1. ; outpatient visits. Be sure to close the query object
  1. ; when done
  1. ;
  1. ; Pre-set variables IB array, IBBDT, IBEDT, IBDIV, IBSORT 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. ; - Check if patient is deceased; get date of death.
  1. S IBDOD=$S(+$G(^DPT(DFN,.35)):^(.35)\1,1:"")
  1. I IBDOD S IB(IBDIV,"DEC")=IB(IBDIV,"DEC")+1
  1. ;
  1. ; - Set patient index and 'total patients' accumulator.
  1. S ^TMP("IBJDI31",$J,DFN)="",IB(IBDIV,"TOT")=IB(IBDIV,"TOT")+1
  1. ;
  1. S IBDN=$G(^DPT(DFN,0)),IBEMP=$G(^(.311)),IBES=$P(IBEMP,U,15)
  1. ;
  1. ; - Empl. status is null/unknown, employed (full/part), or retired
  1. ; AND no employer is specified.
  1. I $P(IBEMP,U)="",(IBES=""!("^1^2^5^9^"[("^"_IBES_"^"))) D G PRCQ
  1. .S IB(IBDIV,"NO")=IB(IBDIV,"NO")+1 I IBRPT="D" D SET(.IBQUERY)
  1. S IB(IBDIV,"OK")=IB(IBDIV,"OK")+1
  1. ;
  1. PRCQ K VA,VAERR,VAEL
  1. Q
  1. ;
  1. SET(IBQUERY) ; - Set up detailed information for pts to appear on the report.
  1. ; Input: IBQUERY = The # of the QUERY OBJECT to be used to extract
  1. ; outpatient visits
  1. ;
  1. ; Pre-set variable IBDIV is reqiured.
  1. ;
  1. ; - Find last treatment date (LTD).
  1. S (IBDT,IBLT)=0 F S IBDT=$O(^DGPM("ATID3",DFN,IBDT)) Q:+IBDT=0 D
  1. .S IBDTF=9999999.9999999-IBDT\1
  1. .S:IBDTF>IBLT IBLT=IBDTF Q:IBDTF<IBBDT!(IBDTF>IBEDT)
  1. ;
  1. ; - Look through outpatient encounters.
  1. D OUTPT^IBJDI21(DFN,IBBDT,IBEDT,"S IBOED=Y0,IBDT=+IBOED,IBDTF=IBDT\1 S:IBDTF>IBLT IBLT=IBDTF","","","",.IBQUERY)
  1. ;
  1. ; - If current inpatient, set LTD to today.
  1. I $G(^DPT(DFN,.105)) S IBLT=DT
  1. ;
  1. SETC S ^TMP("IBJDI32",$J,IBDIV,$P(IBDN,U)_IBIPC_"@@"_DFN)=$P(IBDN,U,9)_U_IBES_U_IBLT_U_IBDOD
  1. Q
  1. ;
  1. DIV(X) ; - Return division name.
  1. Q $P($G(^DG(40.8,X,0)),U)
  1. ;
  1. DET ; - Print the detailed report.
  1. D HDET Q:IBQ
  1. I '$D(^TMP("IBJDI32",$J,IBDIV)) W !!,"There were no patients treated in this date range missing an employer." G DETQ
  1. ;
  1. S IBXX="" F S IBXX=$O(^TMP("IBJDI32",$J,IBDIV,IBXX)) Q:IBXX="" S IBX=^(IBXX) D Q:IBQ
  1. .I $Y>(IOSL-4) D PAUSE Q:IBQ D HDET Q:IBQ
  1. .W !,$P(IBXX,"@@"),?34,$$SSN($P(IBX,U))
  1. .S X=$$EXPAND^IBJD(2,.31115,$P(IBX,U,2)) W ?50,$S(X="":"UNANSWERED",1:X)
  1. .W ?72,$$DAT2^IBOUTL($P(IBX,U,3)),?90,$$DAT2^IBOUTL($P(IBX,U,4))
  1. ;
  1. DETQ I 'IBQ D PAUSE
  1. Q
  1. ;
  1. HDET ; - Write the detail report header.
  1. I $E(IOST,1,2)="C-"!(IBPAG) W @IOF,*13
  1. S IBPAG=IBPAG+1
  1. W "No Employer Listing",$S(IBDIV'="ALL":" for "_IBDIV,1:""),?80,"Run Date: ",IBRUN,?123,"Page: ",IBPAG
  1. W !,"Patients without an employer treated in the period ",$$DAT1^IBOUTL(IBBDT)," to ",$$DAT1^IBOUTL(IBEDT)," ('*' = Had inpatient care)"
  1. W !,"Patient",?34,"SSN",?50,"Employment Status",?72,"Last Trmt Date",?90,"Date of Death"
  1. W !,$$DASH(132),!
  1. S IBQ=$$STOP^IBOUTL("No Employer Listing")
  1. Q
  1. ;
  1. SUM ; - Print the summary report.
  1. I $E(IOST,1,2)="C-"!(IBPAG) W @IOF,*13
  1. S IBPAG=IBPAG+1
  1. W !!?30,"NO EMPLOYER LISTING",?71,"Page: ",IBPAG,!
  1. I IBDIV'="ALL" W ?(61-$L(IBDIV))\2,"SUMMARY REPORT for ",IBDIV
  1. E W ?33,"SUMMARY REPORT"
  1. W !!?19,"Patients treated from ",$$DAT1^IBOUTL(IBBDT)," - ",$$DAT1^IBOUTL(IBEDT)
  1. W !!?24,"Run Date: ",IBRUN,!?17,$$DASH(45),!!
  1. ;
  1. S IBPER=$J($S('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"NO")/IB(IBDIV,"TOT")*100),0,2)
  1. W ?24,"Number of Patients Treated:",?53,$J(IB(IBDIV,"TOT"),5)
  1. W !?23,"Number of Deceased Patients:",?53,$J(IB(IBDIV,"DEC"),5),?62,"(",$J($S('IB(IBDIV,"DEC"):0,1:IB(IBDIV,"DEC")/IB(IBDIV,"TOT")*100),0,2),"%)"
  1. W !?3,"Number of Patients Employed without an Employer:",?53,$J(IB(IBDIV,"NO"),5),$S(IB(IBDIV,"NO"):"*",1:""),?62,"(",IBPER,"%)"
  1. W !," Number of Patients Unemployed or with an Employer:",?53,$J(IB(IBDIV,"OK"),5),?62,"(",$J($S('IBPER:0,1:100-IBPER),0,2),"%)"
  1. I IB(IBDIV,"NO") D
  1. .W !!!!!?2,"*This is the total number of veterans who have no employer on file, but"
  1. .W !,?3,"have an employment status of Full-Time, Part-Time, Retired, Unknown or",!?3,"null."
  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 IBX,DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
  1. F IBX=$Y:1:(IOSL-3) W !
  1. S DIR(0)="E" D ^DIR I $D(DIRUT)!($D(DUOUT)) S IBQ=1
  1. Q
  1. ;
  1. SSN(X) ; - Format the SSN.
  1. Q $S(X]"":$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,10),1:"")
  1. ;
  1. DHLP ; - 'Sort by division' prompt.
  1. W !!,"Select: '<CR>' to print the trend report without regard to"
  1. W !?15,"division"
  1. W !?11,"'Y' to select those divisions for which a separate"
  1. W !?15,"trend report should be created",!?11,"'^' to quit"
  1. Q