- IBJDI21 ;ALB/CPM - VETERANS WITH UNVERIFIED ELIGIBILITY (CONT'D) ;16-DEC-96
- ;;2.0;INTEGRATED BILLING;**118,249**;21-MAR-94
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- ; - Find inpatients treated within the user-specified date range.
- S IBD=IBBDT-.01 F S IBD=$O(^DGPM("ATT3",IBD)) Q:'IBD!(IBD\1>IBEDT) D Q:IBQ
- .S IBPM=0 F S IBPM=$O(^DGPM("ATT3",IBD,IBPM)) Q:'IBPM D Q:IBQ
- ..I IBPM#100=0 Q:$$STOP(.IBQ,"Unverified Eligibility Report")
- ..S IBPMD=$G(^DGPM(IBPM,0)) Q:'IBPMD
- ..I IBSORT S IBDIV=$$DIV(1,+$P(IBPMD,U,6)) Q:'$D(IB(IBDIV))
- ..S DFN=+$P(IBPMD,U,3) Q:'DFN
- ..;
- ..; - Process patient.
- ..I '$D(^TMP("IBJDI21",$J,DFN)) D PROC(DFN,"*",.IBQUERY)
- ;
- D CLOSE^IBSDU(.IBQUERY)
- I IBQ G ENQ
- ;
- ; - Find outpatients treated within the user-specified date range.
- D OUTPT("",IBBDT,IBEDT,"S:IBQ SDSTOP=1 I 'IBQ,$$ENCHK^IBJDI5(Y0) D ENC^IBJDI21(Y0,.IBQUERY1)","Unverified Eligibility Report",.IBQ,"IBJDI21",.IBQUERY)
- D CLOSE^IBSDU(.IBQUERY),CLOSE^IBSDU(.IBQUERY1)
- ;
- I IBQ G ENQ
- ;
- ; - Extract summary data.
- I $G(IBXTRACT) D G ENQ
- .F X="DEC","NOT","PEN","TOT","VER","VERO" S IB(X)=$G(IB("ALL",X))
- .D E^IBJDE(2,0)
- ;
- ; - If detail, look up next appt
- I IBRPT="D" S IBARRAY("SORT")="P",IBARRAY("FLDS")=1,IBARRAY(1)=$$NOW^XLFDT_";9999999",IBARRAY(4)="^TMP(""IBDFN"",$J,",IBCOUNT=$$SDAPI^SDAMA301(.IBARRAY)
- ;
- ; - 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 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 "_$S($G(IBSUBSCR)'="":"'$D(^TMP(IBSUBSCR,$J,+$P(Y0,U,2))),",1:"")_"'$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")
- D SCAN^IBSDU($S($G(DFN):"PATIENT/DATE",1:"DATE/TIME"),.IBVAL,IBFILTER,IBCBK,0,.IBQUERY,IBDIR) K ^TMP("DIERR",$J)
- Q
- ;
- STOP(IBQ,MSG) ; - Check if user wants to stop.
- N Y,Y0 S IBQ=$$STOP^IBOUTL(MSG)
- Q IBQ
- ;
- ENC(IBOED,IBQUERY1) ; - Encounter extract for all patients loop.
- ; IBQUERY1 = the # of the QUERY to use to do the extract.
- ; Pre-set variables IB array, IBSORT are required.
- ;
- I IBSORT S IBDIV=$$DIV(0,+$P(IBOED,U,11)) Q:'$D(IB(IBDIV))
- D PROC(+$P(IBOED,U,2),"",.IBQUERY1) ; Process patient.
- Q
- ;
- PROC(DFN,IBIPC,IBQUERY) ; - Process each specific patient.
- ; Input: DFN = Pointer to the patient in file #2
- ; IBIPC = Inpatient treatment marker
- ; ("*"=Had inpat. treatment, null=No inpat. treatment)
- ; IBQUERY = The # of the QUERY OBJECT to be used to extract
- ; outpatient visits
- ;
- ; Pre-set variables IB array, IBDIV are required.
- ;
- I $$TESTP^IBJDI1(DFN) Q ; Test patient.
- D ELIG^VADPT I 'VAEL(4) G PRCQ ; Patient is not a vet.
- ;
- ; - Set patient index and 'total' accumulator.
- S ^TMP("IBJDI21",$J,DFN)="",IB(IBDIV,"TOT")=IB(IBDIV,"TOT")+1
- ;
- I $G(^DPT(DFN,.35)) S IB(IBDIV,"DEC")=IB(IBDIV,"DEC")+1 ; Deceased.
- ;
- ; - Elig. status is Verified, Pending, Re-pending, or null.
- S IBES=$P(VAEL(8),U)
- I IBES="V" D G PRCS:X'<730,PRCQ
- .S IB(IBDIV,"VER")=IB(IBDIV,"VER")+1
- .S IBESD=+$P($G(^DPT(DFN,.361)),U,2),X1=DT,X2=IBESD D ^%DTC
- .S:X'<730 IB(IBDIV,"VERO")=IB(IBDIV,"VERO")+1,^TMP("IBJDI23",$J,DFN)=" (on "_$$DAT1^IBOUTL(IBESD)_")"
- I IBES="P"!(IBES="R") S IB(IBDIV,"PEN")=IB(IBDIV,"PEN")+1 G PRCS
- S IB(IBDIV,"NOT")=IB(IBDIV,"NOT")+1
- ;
- PRCS I IBRPT="D" D SET(.IBQUERY)
- ;
- PRCQ K VA,VAERR,VAEL
- Q
- ;
- SET(IBQUERY) ; - Set up detailed information to appear on the report.
- ; Working variable definitions:
- ; IBLT = Last treatment date
- ; IBDN = Zero node of Patient file entry
- ; IBDOD = Patient's date of death (if any)
- ; IBNUMO = No. outpatient visits in date range
- ; IBNUMD = No. discharges in date range
- ; IBNEXT = Next scheduled treatment date
- ; IBQUERY = The # of the QUERY OBJECT to be used to extract outpatient
- ; visits
- ;
- S (IBNUMD,IBNUMO,IBLT)=0
- ;
- ; - Get # of discharges; look for LTD.
- S IBDT=0 F S IBDT=$O(^DGPM("ATID3",DFN,IBDT)) Q:'IBDT D
- .S IBDTF=9999999.9999999-IBDT\1
- .S:IBDTF>IBLT IBLT=IBDTF I IBDTF<IBBDT!(IBDTF>IBEDT) Q
- .S IBNUMD=IBNUMD+1
- ;
- ; - Get # of outpatient visits; look for LTD.
- D OUTPT(DFN,IBBDT,9991231,"S IBDTF=Y0\1 S:IBDTF>IBLT IBLT=IBDTF I IBDTF'<IBBDT,IBDTF'>IBEDT S IBNUMO=IBNUMO+1","","","",.IBQUERY)
- ;
- ; - If current inpatient, set LTD to today.
- I $G(^DPT(DFN,.105)) S IBLT=DT
- ;
- ; - Find next scheduled treatment date.
- S IBNEXT=""
- I $$GETICN^MPIF001(DFN) S ^TMP("IBDFN",$J,DFN)="" ;set tmp sched appt.
- S X=0 F S X=$O(^DGS(41.1,"B",DFN,X)) Q:'X D ; Scheduled adm.
- .S X1=$G(^DGS(41.1,X,0))
- .S X2=$P(X1,U,2)\1
- .I X2<DT Q ; Must be old scheduled admission.
- .I $P(X1,U,13) Q ; Sched adm is cancelled.
- .I $P(X1,U,17) Q ; Patient already admitted.
- .I X2>IBNEXT S IBNEXT=X2
- ;
- S IBDN=$G(^DPT(DFN,0))
- S IBDOD=$S(+$G(^DPT(DFN,.35)):$$DAT1^IBOUTL(+$G(^(.35))\1),1:"")
- ;
- S ^TMP("IBJDI22",$J,IBDIV,$E($P(IBDN,U),1,25)_IBIPC_"@@"_DFN)=$P(IBDN,U,9)_U_$E($P(VAEL(1),U,2),1,23)_U_IBES_U_IBNUMO_U_IBNUMD_U_IBLT_U_IBNEXT_U_IBDOD
- Q
- ;
- DIV(X,Y) ; - Return division name.
- ; Input: X=1-Inpatient, 0-Outpatient
- ; Y=IEN of file #42 (If X=1) or IEN of file #40.8 (If X=0)
- I X S Y=+$P($G(^DIC(42,Y,0)),U,11)
- S Z=$P($G(^DG(40.8,Y,0)),U) I Z="" S Z=$P($$SITE^VASITE,U,2)
- Q Z
- ;
- DET ; - Print the detailed report.
- D HDET Q:IBQ
- I '$D(^TMP("IBJDI22",$J,IBDIV)) W !!,"There were no patients treated in this date range with unverified eligibility." G DETQ
- ;
- S IBXX="" F S IBXX=$O(^TMP("IBJDI22",$J,IBDIV,IBXX)) Q:IBXX="" S IBX=^(IBXX) D Q:IBQ
- .I $Y>(IOSL-2) D PAUSE Q:IBQ D HDET Q:IBQ
- .W !,$P(IBXX,"@@"),?28,$$SSN($P(IBX,U)),?42,$P(IBX,U,2)
- .W ?67,$$ESTAT($P(IBX,U,3)),$G(^TMP("IBJDI23",$J,IBDIV,+$P(IBXX,"@@",2)))
- .W ?93,$J($P(IBX,U,4),3),?98,$J($P(IBX,U,5),3)
- .W ?104,$$DAT1^IBOUTL($P(IBX,U,6))
- .S IBCOUNT=$O(^TMP($J,"SDAMA301",+$P(IBXX,"@@",2),0))
- .S:IBCOUNT $P(IBX,"^",7)=$S('$P(IBX,"^",7):IBCOUNT,IBCOUNT<$P(IBX,"^",7):IBCOUNT,1:$P(IBX,"^",7))
- .W ?114,$$DAT1^IBOUTL($P(IBX,U,7))
- .W ?124,$P(IBX,U,8)
- ;
- DETQ I 'IBQ D PAUSE
- Q
- ;
- HDET ; - Write the detail report header.
- I $E(IOST,1,2)="C-"!(IBPAG) W @IOF,*13
- S IBPAG=IBPAG+1
- W !,"Veterans with Unverified Eligibilities",$S(IBDIV'="ALL":" for "_IBDIV,1:""),?80,"Run Date: ",IBRUN,?123,"Page: ",IBPAG
- W !,"Patients who were treated in the period ",$$DAT1^IBOUTL(IBBDT)," to ",$$DAT1^IBOUTL(IBEDT)
- W !?91,"# Opt # Last Nxt Sched Date of"
- W !,"Patient (*=Had inpt. care)",?28,"SSN",?42,"Primary Eligibility"
- W ?67,"Eligibility Status",?91,"Visits Disc Seen Visit/Adm Death"
- W !,$$DASH(IOM),!
- S IBQ=$$STOP(0,"Unverified Eligibility Report")
- Q
- ;
- SUM ; - Print the summary report.
- I $E(IOST,1,2)="C-"!(IBPAG) W @IOF,*13
- S IBPAG=IBPAG+1
- W !!?21,"VETERANS WITH UNVERIFIED ELIGIBILITY",!
- I IBDIV'="ALL" W ?(61-$L(IBDIV))\2,"SUMMARY REPORT for ",IBDIV
- E W ?33,"SUMMARY REPORT"
- W !!?19,"Patients treated from ",$$DAT1^IBOUTL(IBBDT)," - ",$$DAT1^IBOUTL(IBEDT)
- W !!?24,"Run Date: ",IBRUN,!?13,$$DASH(53),!!
- ;
- S IBPERV=$J($S('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"VER")/IB(IBDIV,"TOT")*100),0,2)
- S IBPERP=$J($S('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"PEN")/IB(IBDIV,"TOT")*100),0,2)
- S IBPERD=$J($S('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"DEC")/IB(IBDIV,"TOT")*100),0,2)
- S IBPERO=$J($S('IB(IBDIV,"VER"):0,1:IB(IBDIV,"VERO")/IB(IBDIV,"VER")*100),0,2)
- W ?29,"Number of Patients Treated:",?58,$J(IB(IBDIV,"TOT"),5)
- W !?28,"Number of Deceased Patients:",?58,$J(IB(IBDIV,"DEC"),5),?67,"(",IBPERD,"%)"
- W !?11,"Number of Patients with Verified Eligibility:",?58,$J(IB(IBDIV,"VER"),5),?67,"(",IBPERV,"%)"
- W !?5,"Number of Patients Whose Verified Eligibility Date"
- W !?13,"is At Least 2 Years Old (from above total):",?58,$J(IB(IBDIV,"VERO"),5),?67,"(",IBPERO,"%)"
- W !?10,"Number of Patients with a Pending Eligibility:",?58,$J(IB(IBDIV,"PEN"),5),?67,"(",IBPERP,"%)"
- W !?24,"Number of Patients Not Verified:",?58,$J(IB(IBDIV,"NOT"),5),?67,"(",$J($S('IB(IBDIV,"TOT"):0,1:100-IBPERV-IBPERP),0,2),"%)"
- 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
- ;
- SSN(X) ; - Format the SSN.
- Q $S(X]"":$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,10),1:"")
- ;
- ESTAT(X) ; - Decode the eligibility status.
- Q $S(X="V":"VERIFIED",X="P":"PENDING VERIFICATION",X="R":"PENDING RE-VERIFICATION",1:"NOT VERIFIED")
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBJDI21 9611 printed Mar 13, 2025@21:28:15 Page 2
- IBJDI21 ;ALB/CPM - VETERANS WITH UNVERIFIED ELIGIBILITY (CONT'D) ;16-DEC-96
- +1 ;;2.0;INTEGRATED BILLING;**118,249**;21-MAR-94
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ;
- +4 ; - Find inpatients treated within the user-specified date range.
- +5 SET IBD=IBBDT-.01
- FOR
- SET IBD=$ORDER(^DGPM("ATT3",IBD))
- if 'IBD!(IBD\1>IBEDT)
- QUIT
- Begin DoDot:1
- +6 SET IBPM=0
- FOR
- SET IBPM=$ORDER(^DGPM("ATT3",IBD,IBPM))
- if 'IBPM
- QUIT
- Begin DoDot:2
- +7 IF IBPM#100=0
- if $$STOP(.IBQ,"Unverified Eligibility Report")
- QUIT
- +8 SET IBPMD=$GET(^DGPM(IBPM,0))
- if 'IBPMD
- QUIT
- +9 IF IBSORT
- SET IBDIV=$$DIV(1,+$PIECE(IBPMD,U,6))
- if '$DATA(IB(IBDIV))
- QUIT
- +10 SET DFN=+$PIECE(IBPMD,U,3)
- if 'DFN
- QUIT
- +11 ;
- +12 ; - Process patient.
- +13 IF '$DATA(^TMP("IBJDI21",$JOB,DFN))
- DO PROC(DFN,"*",.IBQUERY)
- End DoDot:2
- if IBQ
- QUIT
- End DoDot:1
- if IBQ
- QUIT
- +14 ;
- +15 DO CLOSE^IBSDU(.IBQUERY)
- +16 IF IBQ
- GOTO ENQ
- +17 ;
- +18 ; - Find outpatients treated within the user-specified date range.
- +19 DO OUTPT("",IBBDT,IBEDT,"S:IBQ SDSTOP=1 I 'IBQ,$$ENCHK^IBJDI5(Y0) D ENC^IBJDI21(Y0,.IBQUERY1)","Unverified Eligibility Report",.IBQ,"IBJDI21",.IBQUERY)
- +20 DO CLOSE^IBSDU(.IBQUERY)
- DO CLOSE^IBSDU(.IBQUERY1)
- +21 ;
- +22 IF IBQ
- GOTO ENQ
- +23 ;
- +24 ; - Extract summary data.
- +25 IF $GET(IBXTRACT)
- Begin DoDot:1
- +26 FOR X="DEC","NOT","PEN","TOT","VER","VERO"
- SET IB(X)=$GET(IB("ALL",X))
- +27 DO E^IBJDE(2,0)
- End DoDot:1
- GOTO ENQ
- +28 ;
- +29 ; - If detail, look up next appt
- +30 IF IBRPT="D"
- SET IBARRAY("SORT")="P"
- SET IBARRAY("FLDS")=1
- SET IBARRAY(1)=$$NOW^XLFDT_";9999999"
- SET IBARRAY(4)="^TMP(""IBDFN"",$J,"
- SET IBCOUNT=$$SDAPI^SDAMA301(.IBARRAY)
- +31 ;
- +32 ; - Print the reports.
- +33 SET IBQ=0
- DO NOW^%DTC
- SET IBRUN=$$DAT2^IBOUTL(%)
- +34 SET IBDIV=""
- FOR
- SET IBDIV=$ORDER(IB(IBDIV))
- if IBDIV=""
- QUIT
- Begin DoDot:1
- +35 SET IBPAG=0
- if IBRPT="D"
- DO DET
- IF 'IBQ
- DO SUM
- DO PAUSE
- End DoDot:1
- if IBQ
- QUIT
- +36 ;
- ENQ QUIT
- +1 ;
- 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 "_$SELECT($GET(IBSUBSCR)'="":"'$D(^TMP(IBSUBSCR,$J,+$P(Y0,U,2))),",1:"")_"'$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 DO SCAN^IBSDU($SELECT($GET(DFN):"PATIENT/DATE",1:"DATE/TIME"),.IBVAL,IBFILTER,IBCBK,0,.IBQUERY,IBDIR)
- KILL ^TMP("DIERR",$JOB)
- +22 QUIT
- +23 ;
- STOP(IBQ,MSG) ; - Check if user wants to stop.
- +1 NEW Y,Y0
- SET IBQ=$$STOP^IBOUTL(MSG)
- +2 QUIT IBQ
- +3 ;
- ENC(IBOED,IBQUERY1) ; - Encounter extract for all patients loop.
- +1 ; IBQUERY1 = the # of the QUERY to use to do the extract.
- +2 ; Pre-set variables IB array, IBSORT are required.
- +3 ;
- +4 IF IBSORT
- SET IBDIV=$$DIV(0,+$PIECE(IBOED,U,11))
- if '$DATA(IB(IBDIV))
- QUIT
- +5 ; Process patient.
- DO PROC(+$PIECE(IBOED,U,2),"",.IBQUERY1)
- +6 QUIT
- +7 ;
- PROC(DFN,IBIPC,IBQUERY) ; - Process each specific patient.
- +1 ; Input: DFN = Pointer to the patient in file #2
- +2 ; IBIPC = Inpatient treatment marker
- +3 ; ("*"=Had inpat. treatment, null=No inpat. treatment)
- +4 ; IBQUERY = The # of the QUERY OBJECT to be used to extract
- +5 ; outpatient visits
- +6 ;
- +7 ; Pre-set variables IB array, IBDIV are required.
- +8 ;
- +9 ; Test patient.
- IF $$TESTP^IBJDI1(DFN)
- QUIT
- +10 ; Patient is not a vet.
- DO ELIG^VADPT
- IF 'VAEL(4)
- GOTO PRCQ
- +11 ;
- +12 ; - Set patient index and 'total' accumulator.
- +13 SET ^TMP("IBJDI21",$JOB,DFN)=""
- SET IB(IBDIV,"TOT")=IB(IBDIV,"TOT")+1
- +14 ;
- +15 ; Deceased.
- IF $GET(^DPT(DFN,.35))
- SET IB(IBDIV,"DEC")=IB(IBDIV,"DEC")+1
- +16 ;
- +17 ; - Elig. status is Verified, Pending, Re-pending, or null.
- +18 SET IBES=$PIECE(VAEL(8),U)
- +19 IF IBES="V"
- Begin DoDot:1
- +20 SET IB(IBDIV,"VER")=IB(IBDIV,"VER")+1
- +21 SET IBESD=+$PIECE($GET(^DPT(DFN,.361)),U,2)
- SET X1=DT
- SET X2=IBESD
- DO ^%DTC
- +22 if X'<730
- SET IB(IBDIV,"VERO")=IB(IBDIV,"VERO")+1
- SET ^TMP("IBJDI23",$JOB,DFN)=" (on "_$$DAT1^IBOUTL(IBESD)_")"
- End DoDot:1
- if X'<730
- GOTO PRCS
- GOTO PRCQ
- +23 IF IBES="P"!(IBES="R")
- SET IB(IBDIV,"PEN")=IB(IBDIV,"PEN")+1
- GOTO PRCS
- +24 SET IB(IBDIV,"NOT")=IB(IBDIV,"NOT")+1
- +25 ;
- PRCS IF IBRPT="D"
- DO SET(.IBQUERY)
- +1 ;
- PRCQ KILL VA,VAERR,VAEL
- +1 QUIT
- +2 ;
- SET(IBQUERY) ; - Set up detailed information to appear on the report.
- +1 ; Working variable definitions:
- +2 ; IBLT = Last treatment date
- +3 ; IBDN = Zero node of Patient file entry
- +4 ; IBDOD = Patient's date of death (if any)
- +5 ; IBNUMO = No. outpatient visits in date range
- +6 ; IBNUMD = No. discharges in date range
- +7 ; IBNEXT = Next scheduled treatment date
- +8 ; IBQUERY = The # of the QUERY OBJECT to be used to extract outpatient
- +9 ; visits
- +10 ;
- +11 SET (IBNUMD,IBNUMO,IBLT)=0
- +12 ;
- +13 ; - Get # of discharges; look for LTD.
- +14 SET IBDT=0
- FOR
- SET IBDT=$ORDER(^DGPM("ATID3",DFN,IBDT))
- if 'IBDT
- QUIT
- Begin DoDot:1
- +15 SET IBDTF=9999999.9999999-IBDT\1
- +16 if IBDTF>IBLT
- SET IBLT=IBDTF
- IF IBDTF<IBBDT!(IBDTF>IBEDT)
- QUIT
- +17 SET IBNUMD=IBNUMD+1
- End DoDot:1
- +18 ;
- +19 ; - Get # of outpatient visits; look for LTD.
- +20 DO OUTPT(DFN,IBBDT,9991231,"S IBDTF=Y0\1 S:IBDTF>IBLT IBLT=IBDTF I IBDTF'<IBBDT,IBDTF'>IBEDT S IBNUMO=IBNUMO+1","","","",.IBQUERY)
- +21 ;
- +22 ; - If current inpatient, set LTD to today.
- +23 IF $GET(^DPT(DFN,.105))
- SET IBLT=DT
- +24 ;
- +25 ; - Find next scheduled treatment date.
- +26 SET IBNEXT=""
- +27 ;set tmp sched appt.
- IF $$GETICN^MPIF001(DFN)
- SET ^TMP("IBDFN",$JOB,DFN)=""
- +28 ; Scheduled adm.
- SET X=0
- FOR
- SET X=$ORDER(^DGS(41.1,"B",DFN,X))
- if 'X
- QUIT
- Begin DoDot:1
- +29 SET X1=$GET(^DGS(41.1,X,0))
- +30 SET X2=$PIECE(X1,U,2)\1
- +31 ; Must be old scheduled admission.
- IF X2<DT
- QUIT
- +32 ; Sched adm is cancelled.
- IF $PIECE(X1,U,13)
- QUIT
- +33 ; Patient already admitted.
- IF $PIECE(X1,U,17)
- QUIT
- +34 IF X2>IBNEXT
- SET IBNEXT=X2
- End DoDot:1
- +35 ;
- +36 SET IBDN=$GET(^DPT(DFN,0))
- +37 SET IBDOD=$SELECT(+$GET(^DPT(DFN,.35)):$$DAT1^IBOUTL(+$GET(^(.35))\1),1:"")
- +38 ;
- +39 SET ^TMP("IBJDI22",$JOB,IBDIV,$EXTRACT($PIECE(IBDN,U),1,25)_IBIPC_"@@"_DFN)=$PIECE(IBDN,U,9)_U_$EXTRACT($PIECE(VAEL(1),U,2),1,23)_U_IBES_U_IBNUMO_U_IBNUMD_U_IBLT_U_IBNEXT_U_IBDOD
- +40 QUIT
- +41 ;
- DIV(X,Y) ; - Return division name.
- +1 ; Input: X=1-Inpatient, 0-Outpatient
- +2 ; Y=IEN of file #42 (If X=1) or IEN of file #40.8 (If X=0)
- +3 IF X
- SET Y=+$PIECE($GET(^DIC(42,Y,0)),U,11)
- +4 SET Z=$PIECE($GET(^DG(40.8,Y,0)),U)
- IF Z=""
- SET Z=$PIECE($$SITE^VASITE,U,2)
- +5 QUIT Z
- +6 ;
- DET ; - Print the detailed report.
- +1 DO HDET
- if IBQ
- QUIT
- +2 IF '$DATA(^TMP("IBJDI22",$JOB,IBDIV))
- WRITE !!,"There were no patients treated in this date range with unverified eligibility."
- GOTO DETQ
- +3 ;
- +4 SET IBXX=""
- FOR
- SET IBXX=$ORDER(^TMP("IBJDI22",$JOB,IBDIV,IBXX))
- if IBXX=""
- QUIT
- SET IBX=^(IBXX)
- Begin DoDot:1
- +5 IF $Y>(IOSL-2)
- DO PAUSE
- if IBQ
- QUIT
- DO HDET
- if IBQ
- QUIT
- +6 WRITE !,$PIECE(IBXX,"@@"),?28,$$SSN($PIECE(IBX,U)),?42,$PIECE(IBX,U,2)
- +7 WRITE ?67,$$ESTAT($PIECE(IBX,U,3)),$GET(^TMP("IBJDI23",$JOB,IBDIV,+$PIECE(IBXX,"@@",2)))
- +8 WRITE ?93,$JUSTIFY($PIECE(IBX,U,4),3),?98,$JUSTIFY($PIECE(IBX,U,5),3)
- +9 WRITE ?104,$$DAT1^IBOUTL($PIECE(IBX,U,6))
- +10 SET IBCOUNT=$ORDER(^TMP($JOB,"SDAMA301",+$PIECE(IBXX,"@@",2),0))
- +11 if IBCOUNT
- SET $PIECE(IBX,"^",7)=$SELECT('$PIECE(IBX,"^",7):IBCOUNT,IBCOUNT<$PIECE(IBX,"^",7):IBCOUNT,1:$PIECE(IBX,"^",7))
- +12 WRITE ?114,$$DAT1^IBOUTL($PIECE(IBX,U,7))
- +13 WRITE ?124,$PIECE(IBX,U,8)
- End DoDot:1
- if IBQ
- QUIT
- +14 ;
- DETQ IF 'IBQ
- DO PAUSE
- +1 QUIT
- +2 ;
- HDET ; - Write the detail report header.
- +1 IF $EXTRACT(IOST,1,2)="C-"!(IBPAG)
- WRITE @IOF,*13
- +2 SET IBPAG=IBPAG+1
- +3 WRITE !,"Veterans with Unverified Eligibilities",$SELECT(IBDIV'="ALL":" for "_IBDIV,1:""),?80,"Run Date: ",IBRUN,?123,"Page: ",IBPAG
- +4 WRITE !,"Patients who were treated in the period ",$$DAT1^IBOUTL(IBBDT)," to ",$$DAT1^IBOUTL(IBEDT)
- +5 WRITE !?91,"# Opt # Last Nxt Sched Date of"
- +6 WRITE !,"Patient (*=Had inpt. care)",?28,"SSN",?42,"Primary Eligibility"
- +7 WRITE ?67,"Eligibility Status",?91,"Visits Disc Seen Visit/Adm Death"
- +8 WRITE !,$$DASH(IOM),!
- +9 SET IBQ=$$STOP(0,"Unverified Eligibility Report")
- +10 QUIT
- +11 ;
- SUM ; - Print the summary report.
- +1 IF $EXTRACT(IOST,1,2)="C-"!(IBPAG)
- WRITE @IOF,*13
- +2 SET IBPAG=IBPAG+1
- +3 WRITE !!?21,"VETERANS WITH UNVERIFIED ELIGIBILITY",!
- +4 IF IBDIV'="ALL"
- WRITE ?(61-$LENGTH(IBDIV))\2,"SUMMARY REPORT for ",IBDIV
- +5 IF '$TEST
- WRITE ?33,"SUMMARY REPORT"
- +6 WRITE !!?19,"Patients treated from ",$$DAT1^IBOUTL(IBBDT)," - ",$$DAT1^IBOUTL(IBEDT)
- +7 WRITE !!?24,"Run Date: ",IBRUN,!?13,$$DASH(53),!!
- +8 ;
- +9 SET IBPERV=$JUSTIFY($SELECT('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"VER")/IB(IBDIV,"TOT")*100),0,2)
- +10 SET IBPERP=$JUSTIFY($SELECT('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"PEN")/IB(IBDIV,"TOT")*100),0,2)
- +11 SET IBPERD=$JUSTIFY($SELECT('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"DEC")/IB(IBDIV,"TOT")*100),0,2)
- +12 SET IBPERO=$JUSTIFY($SELECT('IB(IBDIV,"VER"):0,1:IB(IBDIV,"VERO")/IB(IBDIV,"VER")*100),0,2)
- +13 WRITE ?29,"Number of Patients Treated:",?58,$JUSTIFY(IB(IBDIV,"TOT"),5)
- +14 WRITE !?28,"Number of Deceased Patients:",?58,$JUSTIFY(IB(IBDIV,"DEC"),5),?67,"(",IBPERD,"%)"
- +15 WRITE !?11,"Number of Patients with Verified Eligibility:",?58,$JUSTIFY(IB(IBDIV,"VER"),5),?67,"(",IBPERV,"%)"
- +16 WRITE !?5,"Number of Patients Whose Verified Eligibility Date"
- +17 WRITE !?13,"is At Least 2 Years Old (from above total):",?58,$JUSTIFY(IB(IBDIV,"VERO"),5),?67,"(",IBPERO,"%)"
- +18 WRITE !?10,"Number of Patients with a Pending Eligibility:",?58,$JUSTIFY(IB(IBDIV,"PEN"),5),?67,"(",IBPERP,"%)"
- +19 WRITE !?24,"Number of Patients Not Verified:",?58,$JUSTIFY(IB(IBDIV,"NOT"),5),?67,"(",$JUSTIFY($SELECT('IB(IBDIV,"TOT"):0,1:100-IBPERV-IBPERP),0,2),"%)"
- +20 QUIT
- +21 ;
- 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 ;
- SSN(X) ; - Format the SSN.
- +1 QUIT $SELECT(X]"":$EXTRACT(X,1,3)_"-"_$EXTRACT(X,4,5)_"-"_$EXTRACT(X,6,10),1:"")
- +2 ;
- ESTAT(X) ; - Decode the eligibility status.
- +1 QUIT $SELECT(X="V":"VERIFIED",X="P":"PENDING VERIFICATION",X="R":"PENDING RE-VERIFICATION",1:"NOT VERIFIED")
