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