IBCNBOA ;ALB/ARH - Ins Buffer: Activity Report ; 1 Jun 97
;;2.0;INTEGRATED BILLING;**82,305,528,602,702**;21-MAR-94;Build 53
;;Per VA Directive 6402, this routine should not be modified.
;
EN ;get parameters then run the report
;
; IB*702 initialize variables
N IBBA,IBBB,IBBC,IBBD,IBBEG,IBBEGEX,IBBENEX,IBBUFEM,IBBUFEME,IBBUFSD,IBBUFSM,IBBUFSME
N IBCO,IBCUR,IBCURFM,IBEDDT,IBEND,IBHDR,IBMONTH,IBOK,IBOUT,IBSTDT
K ^TMP($J)
;
S IBHDR="INSURANCE BUFFER ACTIVITY REPORT" W @IOF,!!,?25,IBHDR
W !!,"This report contains the counts and time statistics for all activity in the"
W !,"Insurance Buffer.",!!
;
;IB*702/DTG Change question flow, month first, if not month then dates.
; Rewrote month and date prompt, plus behavior with the "^" throughout the routine.
;S IBBEG=$$DATES^IBCNBOE("Beginning") G:'IBBEG EXIT
;S IBEND=$$DATES^IBCNBOE("Ending",IBBEG) G:'IBEND EXIT W !!
;S IBMONTH=$$MONTH^IBCNBOE G:IBMONTH="" EXIT W !!
;
10 ; ask Previous Completed month
S IBMONTH=$$MONTH^IBCNBOE G:IBMONTH="" EXIT
;W !!
;
S (IBBEG,IBEND,IBSTDT,IBEDDT,IBCO,IBBUFSM,IBBUFSME,IBBUFEM,IBBUFEME,IBBUFSD)=""
;get current month/year
S IBCURFM=$E(DT,1,5),IBCUR=$$EXMON(IBCURFM)
;
I IBMONTH S IBOK=0 D I 'IBOK G 10
. ; get buffer starting month/year
. S IBBUFSD=$O(^IBA(355.33,"B",0))
. I 'IBBUFSD W !,"May Not run Month option since there is not a complete 'Month Year'" Q
. I IBBUFSD D
. . ; check if first date is complete month
. . S IBBC=+$E(IBBUFSD,6,7),IBBB=$E(IBBUFSD,1,3) I IBBC'=1 D ;<
. . . ; get first day of next month
. . . S IBBA=+$E(IBBUFSD,4,5)+1 S:$L(IBBA)=1 IBBA="0"_IBBA I IBBA>12 D
. . . . S IBBB=$E(IBBUFSM,1,3)+1,IBBA="01"
. . . S IBBD=IBBB_IBBA_"00.999999",IBBUFSD=$O(^IBA(355.33,"B",IBBD))
. S IBBUFSM=$E(IBBUFSD,1,5)
. I IBBUFSM'="" S IBBUFSME=$$EXMON(IBBUFSM)
. I IBBUFSM'=""&((IBBUFSM=IBCURFM)!(IBBUFSM>IBCURFM)) D S IBOK=0 Q
. . W "May Not run Month option since the buffer start is the current 'Month Year' "_IBCUR
. ; get buffer ending month/year prior to current month/year
. S IBBUFEM=$O(^IBA(355.33,"B",(IBCURFM_"01.000000")),-1),IBBUFEM=$E(IBBUFEM,1,5)
. I IBBUFEM="" W "Incomplete ending buffer entries" S IBOK=0 Q
. S IBBUFEME=$$EXMON(IBBUFEM)
. S IBOK=1
;
109 ; come here for dates if going back
;
; month dates
I IBMONTH S (IBOK,IBCO)=0 D I 'IBOK G:IBCO=2 EXIT G 10
. D 11 I 'IBCO!(IBCO=2) Q
. S IBOK=1
;
; daily dates
I 'IBMONTH S (IBOK,IBCO)=0 D I 'IBOK G:IBCO=2 EXIT G 10
. D 21 I 'IBCO!(IBCO=2) Q
. S IBOK=1
;
30 ; report or excel
S IBOUT=$$OUT^IBCNBOE I IBOUT="" G:$$STOP^IBCNINSU EXIT G 109
I IBOUT="E" W !!,"To avoid undesired wrapping, please enter '0;256;999' at the 'DEVICE:' prompt.",!
;
; IB*702/DTG tweaked device prompt
DEV ;get the device
N POP,ZTDESC,ZTRTN,ZTSAVE
S ZTRTN="RPT^IBCNBOA",ZTDESC=IBHDR,ZTSAVE("IB*")=""
D EN^XUTMDEVQ(ZTRTN,ZTDESC,.ZTSAVE)
I POP G:$$STOP^IBCNINSU EXIT G 30
Q
;
11 ; starting month ; IB*702
;
; starting date
S IBCO=0,IBSTDT=$$IBSM("Beginning","")
I 'IBSTDT S:$$STOP^IBCNINSU IBCO=2 Q
S IBBEGEX=$P(IBSTDT,U,2),IBSTDT=$P(IBSTDT,U,1)
S IBBEG=IBSTDT_"01"
;
12 ; ending month ; IB*702
;
W !
S IBEDDT=$$IBSM("Ending",IBSTDT)
S IBBENEX=$P(IBEDDT,U,2),IBEDDT=$P(IBEDDT,U,1)
I 'IBEDDT G:'$$STOP^IBCNINSU 11 S IBCO=2 Q
S IBEND=$$LAST^IBAGMM(IBEDDT)
S IBCO=1
Q
;
21 ; starting date ; IB*702
;
S IBBEG=$$DATES^IBCNBOE("Beginning") I 'IBBEG S:$$STOP^IBCNINSU IBCO=2 Q
;
22 ; ending date ; IB*702
;
W !
S IBEND=$$DATES^IBCNBOE("Ending",IBBEG) I 'IBEND G:'$$STOP^IBCNINSU 21 S IBCO=2 Q
S IBCO=1
Q
;
IBSM(IBLABEL,IBSTDT) ; START/END MONTH ; IB*702
; IBLABEL - starting or ending month
; IBSTDT - starting month year in FM form
;
N DIR,DIRUT,DUOUT,DTOUT,IBB,IBD,IBL,IBNDT,X,Y
;
S IBD="",IBNDT=$S(IBSTDT'="":IBSTDT,1:IBBUFSM),IBB=$$EXMON($E(IBNDT,1,5))
I $E(IBLABEL,1,3)="Beg" D
. W !!,"Future dates are not allowed and the month selected cannot be later than"
. W !,"the previous month."
. W !,"The month selected must be a complete/full month. The current 'Month Year'"
. W !,"of ("_IBCUR_") is not allowed.",!
IBSMA ; skip back tag
S DIR("?",1)="Enter the "_IBLABEL_" 'Month Year' for the range to be reported."
S DIR("?",2)="Use the Form 'MM YYYY' or '^' to Quit."
S DIR("?",3)="The month selected cannot be later than the previous month."
S DIR("?",4)="The month selected must be a complete/full month."
S DIR("?")="The current 'Month Year' of "_IBCUR_" is not allowed."
S DIR("A")=$G(IBLABEL)_" Month Year (Ex. January 2021)"
S DIR(0)="DO^::EM"
D ^DIR
I Y="" W *7,!,"Please enter the "_IBLABEL_" Month Year or '^' to Quit.",! G IBSMA
I $D(DIRUT)!$D(DUOUT)!$D(DTOUT) S IBD="" G IBSMX
S IBD=$E(Y,1,5) I IBD="" G IBSMX
S IBL=$G(Y(0)) I IBL="" S IBL=$E(IBD,4,5)_" "_($E(IBD,1,3)+1700)
; check range(s)
I IBD=IBCURFM W !,*7,"May Not Select current 'Month Year' "_IBCUR_".",! G IBSMA
I IBD>IBCURFM W !,*7,"Future Dates are not allowed.",! G IBSMA
I IBD<IBNDT W *7,!,"Month Year entered ("_IBL_") is less than minimum entry of ("_IBB_").",! G IBSMA
S IBD=IBD_U_IBL
;
IBSMX ; Exit subroutine
Q IBD
;
EXMON(IBCHGDT) ; change FM year month to external 'month year'
;Input:
; IBCHGDT - year month of FM date (ex: 32107)
;
I IBCHGDT="" Q ""
Q $P("JAN,FEB,MAR,APR,MAY,JUN,JUL,AUG,SEP,OCT,NOV,DEC",",",+$E(IBCHGDT,4,5))_" "_($E(IBCHGDT,1,3)+1700)
;
;
RPT ; run report
;IB*702/TAZ - New variables used during processing.
N IBQUIT,ZTQUEUED,ZTSTOP
;
S IBQUIT=0
;
;Patch 305- QUIT in line below inserted for transmission to ARC
D SEARCH(IBBEG,IBEND,IBMONTH) Q:$G(IBARFLAG) G:IBQUIT EXIT
D PRINT(IBBEG,IBEND,IBOUT)
;
EXIT ; exit report
K ^TMP($J)
Q
;
SEARCH(IBBEG,IBEND,IBMONTH) ; search/sort statistics for activity report
;IB*702/DTG remove IBVER for 'verified' logic
; N IBXST,IBXDT,IBBUFDA,IBB0,IBSTAT,IBTIME,IBS3,IBDATE,IBVER,IBDT2 S IBQUIT=""
N IBXST,IBXDT,IBBUFDA,IBB0,IBSTAT,IBTIME,IBS3,IBDATE,IBDT2 S IBQUIT=""
S IBBEG=$G(IBBEG)-.01,IBEND=$S('$G(IBEND):9999999,1:$P(IBEND,".")+.9)
;
S IBXST="" F S IBXST=$O(^IBA(355.33,"AFST",IBXST)) Q:IBXST="" D Q:IBQUIT
. S IBXDT=+IBBEG F S IBXDT=$O(^IBA(355.33,"AFST",IBXST,IBXDT)) Q:'IBXDT!(IBXDT>IBEND) D S IBQUIT=$$STOP Q:IBQUIT
.. S IBBUFDA=0 F S IBBUFDA=$O(^IBA(355.33,"AFST",IBXST,IBXDT,IBBUFDA)) Q:'IBBUFDA D
... ;
... ;IB*702/DTG remove Set IBVER for 'verified' logic
... ;S IBB0=$G(^IBA(355.33,IBBUFDA,0)),IBSTAT=$P(IBB0,U,4),IBVER=$P(IBB0,U,10)
... S IBB0=$G(^IBA(355.33,IBBUFDA,0)),IBSTAT=$P(IBB0,U,4)
... ;
... ; entered
... I IBXST="E" S IBDATE=+IBB0 I +IBDATE,IBDATE>IBBEG,IBDATE<IBEND D
.... S IBDT2=+$P(IBB0,U,10) I 'IBDT2 S IBDT2=+$P(IBB0,U,5) I 'IBDT2 S IBDT2=$$NOW^XLFDT
.... S IBTIME=+$$FMDIFF^XLFDT(IBDT2,IBDATE,2),IBSTAT="ENTERED",IBS3=1
.... I +$G(IBMONTH) D SET(IBSTAT,$E(IBDATE,1,5),IBS3,IBTIME,IBB0)
.... D SET(IBSTAT,99999,IBS3,IBTIME,IBB0)
... ;
... ;IB*702/DTG remove 'verified' logic
... ; verified
... ;I IBXST="V" S IBDATE=+$P(IBB0,U,10) I +IBDATE,IBDATE>IBBEG,IBDATE<IBEND D
... ;. ;S IBTIME=+$$FMDIFF^XLFDT(IBDATE,+IBB0,2),IBSTAT="VERIFIED",IBS3=2
... ;. ;I +$G(IBMONTH) D SET(IBSTAT,$E(IBDATE,1,5),IBS3,IBTIME,IBB0)
... ;. ;D SET(IBSTAT,99999,IBS3,IBTIME,IBB0)
... ;
... ; processed
... I IBXST="A"!(IBXST="R") S IBDATE=+$P(IBB0,U,5) I +IBDATE,IBDATE>IBBEG,IBDATE<IBEND D
.... S IBDT2=+IBB0
.... S IBTIME=+$$FMDIFF^XLFDT(IBDATE,+IBDT2,2),IBSTAT="UNKNOWN",IBS3=6
.... ;IB*702/DTG remove &V and V
.... ;I $P(IBB0,U,4)="A" S IBS3=3,IBSTAT="ACCEPTED" I 'IBVER S IBS3=4,IBSTAT=IBSTAT_" (&V)"
.... ;I $P(IBB0,U,4)="R" S IBS3=5,IBSTAT="REJECTED" I +IBVER S IBS3=6,IBSTAT=IBSTAT_" (V)"
.... I $P(IBB0,U,4)="A" S IBS3=3,IBSTAT="ACCEPTED"
.... I $P(IBB0,U,4)="R" S IBS3=5,IBSTAT="REJECTED"
.... I +$G(IBMONTH) D SET(IBSTAT,$E(IBDATE,1,5),IBS3,IBTIME,IBB0)
.... D SET(IBSTAT,99999,IBS3,IBTIME,IBB0)
;
Q
;
SET(STAT,S1,S3,TIME,IBB0) ;
D TMP("IBCNBOA",S1,1,S3,TIME,STAT)
I S3<3 D TMP("IBCNBOA",S1,2,1,TIME,"NOT PROCESSED")
I S3>2 D TMP("IBCNBOA",S1,2,2,TIME,"PROCESSED")
D TMP("IBCNBOA",S1,2,9,TIME,"TOTAL")
;
Q:$E(STAT)'="A"
;
D TMP1("IBCNBOAC",S1,+$P(IBB0,U,7),+$P(IBB0,U,8),+$P(IBB0,U,9))
Q
;
TMP(XREF,S1,S2,S3,TIME,NAME) ;
S ^TMP($J,XREF,S1,S2,S3)=NAME
S ^TMP($J,XREF,S1,S2,S3,"CNT")=$G(^TMP($J,XREF,S1,S2,S3,"CNT"))+1
S ^TMP($J,XREF,S1,S2,S3,"TM")=$G(^TMP($J,XREF,S1,S2,S3,"TM"))+TIME
I '$G(^TMP($J,XREF,S1,S2,S3,"HG"))!($G(^TMP($J,XREF,S1,S2,S3,"HG"))<TIME) S ^TMP($J,XREF,S1,S2,S3,"HG")=TIME
I '$G(^TMP($J,XREF,S1,S2,S3,"LS"))!($G(^TMP($J,XREF,S1,S2,S3,"LS"))>TIME) S ^TMP($J,XREF,S1,S2,S3,"LS")=TIME
; IB*702/DTG start call to set stubs
D TMPCHK(XREF,S1,S2,S3,TIME,NAME)
; IB*702/DTG end call to set stubs
Q
;
; IB*702/DTG start set stubs for item entries.
TMPCHK(XREF,S1,S2,S3,TIME,NAME) ; check if not there set stub for all if one is set
; use S1 (date), and S2 1 or 2
N IBBI
I S2=1 F IBBI=1,3,5 I $G(^TMP($J,XREF,S1,S2,IBBI))="" D
. S ^TMP($J,XREF,S1,S2,IBBI)=$P("ENTERED,VERIFIED,ACCEPTED,,REJECTED",",",IBBI)
. S ^TMP($J,XREF,S1,S2,IBBI,"CNT")=""
. S ^TMP($J,XREF,S1,S2,IBBI,"TM")=""
. I $G(^TMP($J,XREF,S1,S2,IBBI,"HG"))="" S ^TMP($J,XREF,S1,S2,IBBI,"HG")=""
. I $G(^TMP($J,XREF,S1,S2,IBBI,"LS"))="" S ^TMP($J,XREF,S1,S2,IBBI,"LS")=""
I S2=2 F IBBI=1,2,9 I $G(^TMP($J,XREF,S1,S2,IBBI))="" D
. S ^TMP($J,XREF,S1,S2,IBBI)=$P("NOT PROCESSED,PROCESSED,,,,,,,TOTAL",",",IBBI)
. S ^TMP($J,XREF,S1,S2,IBBI,"CNT")=""
. S ^TMP($J,XREF,S1,S2,IBBI,"TM")=""
. I $G(^TMP($J,XREF,S1,S2,IBBI,"HG"))="" S ^TMP($J,XREF,S1,S2,IBBI,"HG")=""
. I $G(^TMP($J,XREF,S1,S2,IBBI,"LS"))="" S ^TMP($J,XREF,S1,S2,IBBI,"LS")=""
Q
; IB*702/DTG end set stubs for item entries.
;
TMP1(XREF,S1,IC,GC,PC) ;
I +IC S ^TMP($J,XREF,S1,"I")=$G(^TMP($J,XREF,S1,"I"))+1
I +GC S ^TMP($J,XREF,S1,"G")=$G(^TMP($J,XREF,S1,"G"))+1
I +PC S ^TMP($J,XREF,S1,"P")=$G(^TMP($J,XREF,S1,"P"))+1
S ^TMP($J,XREF,S1,"CNT")=$G(^TMP($J,XREF,S1,"CNT"))+1
Q
;
;
;
PRINT(IBBEG,IBEND,IBOUT) ;
N IBXREF,IBLABLE,IBS1,IBS2,IBS3,IBINS,IBGRP,IBPOL,IBCNT,IBIP,IBGP,IBPP,IBRDT,IBPGN,IBRANGE,IBLN,IBI,IBHED
;
I "^R^E^"'[(U_$G(IBOUT)_U) S IBOUT="R"
S IBRANGE=$S(IBMONTH:IBBEGEX,1:$$FMTE^XLFDT(+IBBEG))_" - "_$S(IBMONTH:IBBENEX,1:$$FMTE^XLFDT(IBEND))
;S IBRANGE=$$FMTE^XLFDT(+IBBEG)_" - "_$$FMTE^XLFDT(IBEND)
S IBRDT=$$FMTE^XLFDT($J($$NOW^XLFDT,0,4),2),IBRDT=$TR(IBRDT,"@"," "),(IBLN,IBPGN)=0
; IB*702/DTG start Combine vars, no data check, end of report
S IBXREF="IBCNBOA",IBS1=""
S IBHED=$S(IBOUT="E":"PHDL",1:"HDR") D @IBHED
I '$D(^TMP($J,IBXREF)) D Q
. W ! W:$G(IBOUT)="R" ?23 W "* * * N O D A T A F O U N D * * *",!
. D EOR(80)
. S IBI=$$PAUSE
;
; Excel output
I IBOUT="E" D S IBI=$$PAUSE Q
. F S IBS1=$O(^TMP($J,IBXREF,IBS1)) D:IBS1="" EOR(132) Q:IBS1="" D
.. D GETLABL ;IB*702/DTG Moved pre-existing code to new function
.. S IBS2=0 F S IBS2=$O(^TMP($J,IBXREF,IBS1,IBS2)) Q:IBS2="" D
... S IBS3="" F S IBS3=$O(^TMP($J,IBXREF,IBS1,IBS2,IBS3)) Q:'IBS3 D PRTLN
.. ;
.. D GETOAC ;IB*702/DTG Moved pre-existing code to new function
.. W U_IBINS_U_IBIP_"%"_U_IBGRP_U_IBGP_"%"_U_IBPOL_U_IBPP_"%"
;
F S IBS1=$O(^TMP($J,IBXREF,IBS1)) D:IBS1="" EOR(80) Q:IBS1="" D:IBLN>(IOSL-17) HDR Q:IBQUIT D S IBLN=IBLN+7
. D GETLABL ;IB*702/DTG Moved pre-existing code to new function
. W !,?(40-($L(IBLABLE)/2)),IBLABLE,!
. W !,?43,"AVERAGE",?56,"LONGEST",?68,"SHORTEST"
. W !,"STATUS",?22,"COUNT",?30,"PERCENT",?43,"# DAYS",?56,"# DAYS",?68,"# DAYS"
. ;
. S IBS2=0 F S IBS2=$O(^TMP($J,IBXREF,IBS1,IBS2)) Q:IBS2="" D S IBLN=IBLN+1
.. W !,"-----------------------------------------------------------------------------"
.. S IBS3="" F S IBS3=$O(^TMP($J,IBXREF,IBS1,IBS2,IBS3)) Q:'IBS3 D PRTLN S IBLN=IBLN+1
. ;
. D GETOAC ;IB*702/DTG Moved pre-existing code to new function
. W !!,?2,IBINS," New Compan",$S(IBINS=1:"y",1:"ies")," (",IBIP,"%), "
. W IBGRP," New Group/Plan",$S(IBGRP=1:"",1:"s")," (",IBGP,"%), "
. W IBPOL," New Patient Polic",$S(IBPOL=1:"y",1:"ies")," (",IBPP,"%)",!
;
; IB*702/DTG end Combine vars, no data check, end of report
;
I 'IBQUIT S IBI=$$PAUSE
Q
;
; IB*702/DTG start Combine parts for excel and report
;
GETLABL ; pick up common values for Excel and Report
;
S IBLABLE=$S(IBS1=99999:"TOTALS",($E(IBBEG,1,5)<IBS1)&($E(IBEND,1,5)>IBS1):$$FMTE^XLFDT(IBS1_"00"),1:"")
I IBLABLE="" D ;<
. S IBLABLE=$$FMTE^XLFDT($S($E(IBBEG,1,5)<IBS1:IBS1_"01",1:IBBEG))_" - "_$$FMTE^XLFDT($S($E(IBEND,1,5)>IBS1:$$SCH^XLFDT("1M(L)",IBS1_11),1:IBEND))
. I $G(IBMONTH)&(IBLABLE["-") S IBLABLE=$$FMTE^XLFDT(IBS1_"00")
Q
;
GETOAC ; pick up items for IBCNBOAC
;
S IBINS=+$G(^TMP($J,"IBCNBOAC",IBS1,"I")),IBGRP=+$G(^TMP($J,"IBCNBOAC",IBS1,"G"))
S IBPOL=+$G(^TMP($J,"IBCNBOAC",IBS1,"P")),IBCNT=+$G(^TMP($J,"IBCNBOAC",IBS1,"CNT"))
S (IBIP,IBGP,IBPP)=0 I IBCNT'=0 S IBIP=((IBINS/IBCNT)*100)\1,IBGP=((IBGRP/IBCNT)*100)\1,IBPP=((IBPOL/IBCNT)*100)\1
Q
;
EOR(IBLE) ; write end of report
I '$G(IBLE) S IBLE=80
W ! W:$G(IBOUT)="R" ?((IBLE\2)-10) W "*** END OF REPORT ***",!
Q
;
EXN(IBBN) ; round number by .05 return with 1st decimal
N IBBW,IBBX,IBBR
S IBBN=+$G(IBBN)
;I IBBN="" Q ""
S IBBW=$S($E(IBBN,1)="-":"-",1:"")
S IBBX=IBBN+(IBBW_.05)
S:$P(IBBX,".",1)="" IBBX="0"_"."_$P(IBBX,".",2)
S IBBR=$P(IBBX,".",1)_"."_+($E($P(IBBX,".",2),1))
Q IBBR
;
PRTLN ; IB*702/DTG Rewrote tag to print zeros for statuses with no counts
N IBSTX,IBCNT,IBTM,IBHG,IBLS,IBTCNT
N IBBA,IBBC,IBBD ;IB*702 added variables
;
S IBSTX=$G(^TMP($J,IBXREF,IBS1,IBS2,IBS3))
;S IBCNT=$G(^TMP($J,IBXREF,IBS1,IBS2,IBS3,"CNT")) Q:'IBCNT ;IB*702 removed quit
S IBCNT=$G(^TMP($J,IBXREF,IBS1,IBS2,IBS3,"CNT"))
S IBTM=$G(^TMP($J,IBXREF,IBS1,IBS2,IBS3,"TM"))
S IBHG=$G(^TMP($J,IBXREF,IBS1,IBS2,IBS3,"HG"))
S IBLS=$G(^TMP($J,IBXREF,IBS1,IBS2,IBS3,"LS"))
;S IBTCNT=$G(^TMP($J,IBXREF,IBS1,2,9,"CNT")) Q:'IBTCNT ;IB*702 removed quit
S IBTCNT=$G(^TMP($J,IBXREF,IBS1,2,9,"CNT"))
;
; Excel output
I IBOUT="E" D Q
. W !,IBLABLE_U_IBSTX_U_$FN(IBCNT,",")_U
. S IBBA=$S((IBCNT'=""&(IBTCNT'="")):((IBCNT/IBTCNT)*100),1:0),IBBC=$$EXN(IBBA) W IBBC_"%"_U
. S IBBA=$S(IBCNT'="":$$STD((IBTM/IBCNT)),1:0),IBBC=$$EXN(IBBA) W IBBC_U
. S IBBA=$$STD(IBHG),IBBC=$$EXN(IBBA) W IBBC_U
. S IBBA=$$STD(IBLS),IBBC=$$EXN(IBBA) W IBBC
;
; Report output
W !,IBSTX,?20,$J($FN(IBCNT,","),7)
S IBBA=$S((IBCNT'=""&(IBTCNT'="")):((IBCNT/IBTCNT)*100),1:0) W ?30,$J(IBBA,6,1),"%"
S IBBA=$S(IBCNT'="":$$STD((IBTM/IBCNT)),1:0) W ?43,$J(IBBA,6,1)
W ?56,$J($$STD(IBHG),6,1),?68,$J($$STD(IBLS),6,1)
Q
;
STD(SEC) ; convert seconds to days
N IBX,IBD,IBS,IBH,DAYS S DAYS="" G:'$G(SEC) STDQ
S IBD=(SEC/86400),IBD=+$P(IBD,".")
S IBS=SEC-(IBD*86400)
S IBH=((IBS/60)/60),IBH=+$J(IBH,0,2)
S DAYS=IBD+(IBH/24)
STDQ Q DAYS
;
HDR ;print the report header
N RM
S IBQUIT=$$STOP Q:IBQUIT
I IBPGN>0 S IBQUIT=$$PAUSE Q:IBQUIT
S RM=$S(IBOUT="R":80,1:IOM)
S IBPGN=IBPGN+1,IBLN=4 I IBPGN>1!($E(IOST,1,2)["C-") W @IOF
W !,"INS BUFFER ACTIVITY REPORT ",IBRANGE," "
W ?(RM-22),IBRDT,?(RM-(6+$L(IBPGN)))," PAGE ",IBPGN,!
S IBI="",$P(IBI,"-",RM+1)="" W IBI,!
Q
;
PHDL ; - Print the header line for the Excel spreadsheet
;IB*702/TAZ - Cleaned up code
; IB*602/HN ; Add report headers to Excel Spreadsheets
W !,"INS BUFFER ACTIVITY REPORT^",IBRANGE_"^"_$$FMTE^XLFDT($$NOW^XLFDT,1),!
; IB*602/HN end
W "MONTH^STATUS^COUNT^PERCENT^AVERAGE # DAYS^LONGEST # DAYS^SHORTEST # DAYS^New Companies^% New Companies^New Group/Plans^% New Group/Plans^New Patient Policies^% New Patient Policies"
Q
;
PAUSE() ;pause at end of screen if being displayed on a terminal
N IBX,DIRUT,DUOUT,DTOUT,X,Y
S IBX=0
I $E(IOST,1,2)["C-" W !! S DIR(0)="E" D ^DIR K DIR I $D(DUOUT)!($D(DIRUT)) S IBX=1
Q IBX
;
STOP() ;determine if user has requested the queued report to stop
I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ I +$G(IBPGN) W !,"***TASK STOPPED BY USER***"
Q +$G(ZTSTOP)
;
IBAR(IBBEG,IBEND) ;Entry point for Vista IB AR data to ARC
;patch 305 - called by IBRFN4
N IBMONTH,IBARFLAG,IBARDATA,IBTM,IBCNT
S IBMONTH=0,IBARFLAG=1 K ^TMP($J)
D RPT
S IBTM=$G(^TMP($J,"IBCNBOA",99999,2,2,"TM"))
S IBCNT=$G(^TMP($J,"IBCNBOA",99999,2,2,"CNT"))
I 'IBCNT S IBARDATA=0 G IBARQ
S IBARDATA=$FN($$STD((IBTM/IBCNT)),"",1)
K ^TMP($J)
IBARQ Q IBARDATA
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNBOA 16545 printed Apr 09, 2024@21:28:23 Page 2
IBCNBOA ;ALB/ARH - Ins Buffer: Activity Report ; 1 Jun 97
+1 ;;2.0;INTEGRATED BILLING;**82,305,528,602,702**;21-MAR-94;Build 53
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
EN ;get parameters then run the report
+1 ;
+2 ; IB*702 initialize variables
+3 NEW IBBA,IBBB,IBBC,IBBD,IBBEG,IBBEGEX,IBBENEX,IBBUFEM,IBBUFEME,IBBUFSD,IBBUFSM,IBBUFSME
+4 NEW IBCO,IBCUR,IBCURFM,IBEDDT,IBEND,IBHDR,IBMONTH,IBOK,IBOUT,IBSTDT
+5 KILL ^TMP($JOB)
+6 ;
+7 SET IBHDR="INSURANCE BUFFER ACTIVITY REPORT"
WRITE @IOF,!!,?25,IBHDR
+8 WRITE !!,"This report contains the counts and time statistics for all activity in the"
+9 WRITE !,"Insurance Buffer.",!!
+10 ;
+11 ;IB*702/DTG Change question flow, month first, if not month then dates.
+12 ; Rewrote month and date prompt, plus behavior with the "^" throughout the routine.
+13 ;S IBBEG=$$DATES^IBCNBOE("Beginning") G:'IBBEG EXIT
+14 ;S IBEND=$$DATES^IBCNBOE("Ending",IBBEG) G:'IBEND EXIT W !!
+15 ;S IBMONTH=$$MONTH^IBCNBOE G:IBMONTH="" EXIT W !!
+16 ;
10 ; ask Previous Completed month
+1 SET IBMONTH=$$MONTH^IBCNBOE
if IBMONTH=""
GOTO EXIT
+2 ;W !!
+3 ;
+4 SET (IBBEG,IBEND,IBSTDT,IBEDDT,IBCO,IBBUFSM,IBBUFSME,IBBUFEM,IBBUFEME,IBBUFSD)=""
+5 ;get current month/year
+6 SET IBCURFM=$EXTRACT(DT,1,5)
SET IBCUR=$$EXMON(IBCURFM)
+7 ;
+8 IF IBMONTH
SET IBOK=0
Begin DoDot:1
+9 ; get buffer starting month/year
+10 SET IBBUFSD=$ORDER(^IBA(355.33,"B",0))
+11 IF 'IBBUFSD
WRITE !,"May Not run Month option since there is not a complete 'Month Year'"
QUIT
+12 IF IBBUFSD
Begin DoDot:2
+13 ; check if first date is complete month
+14 ;<
SET IBBC=+$EXTRACT(IBBUFSD,6,7)
SET IBBB=$EXTRACT(IBBUFSD,1,3)
IF IBBC'=1
Begin DoDot:3
+15 ; get first day of next month
+16 SET IBBA=+$EXTRACT(IBBUFSD,4,5)+1
if $LENGTH(IBBA)=1
SET IBBA="0"_IBBA
IF IBBA>12
Begin DoDot:4
+17 SET IBBB=$EXTRACT(IBBUFSM,1,3)+1
SET IBBA="01"
End DoDot:4
+18 SET IBBD=IBBB_IBBA_"00.999999"
SET IBBUFSD=$ORDER(^IBA(355.33,"B",IBBD))
End DoDot:3
End DoDot:2
+19 SET IBBUFSM=$EXTRACT(IBBUFSD,1,5)
+20 IF IBBUFSM'=""
SET IBBUFSME=$$EXMON(IBBUFSM)
+21 IF IBBUFSM'=""&((IBBUFSM=IBCURFM)!(IBBUFSM>IBCURFM))
Begin DoDot:2
+22 WRITE "May Not run Month option since the buffer start is the current 'Month Year' "_IBCUR
End DoDot:2
SET IBOK=0
QUIT
+23 ; get buffer ending month/year prior to current month/year
+24 SET IBBUFEM=$ORDER(^IBA(355.33,"B",(IBCURFM_"01.000000")),-1)
SET IBBUFEM=$EXTRACT(IBBUFEM,1,5)
+25 IF IBBUFEM=""
WRITE "Incomplete ending buffer entries"
SET IBOK=0
QUIT
+26 SET IBBUFEME=$$EXMON(IBBUFEM)
+27 SET IBOK=1
End DoDot:1
IF 'IBOK
GOTO 10
+28 ;
109 ; come here for dates if going back
+1 ;
+2 ; month dates
+3 IF IBMONTH
SET (IBOK,IBCO)=0
Begin DoDot:1
+4 DO 11
IF 'IBCO!(IBCO=2)
QUIT
+5 SET IBOK=1
End DoDot:1
IF 'IBOK
if IBCO=2
GOTO EXIT
GOTO 10
+6 ;
+7 ; daily dates
+8 IF 'IBMONTH
SET (IBOK,IBCO)=0
Begin DoDot:1
+9 DO 21
IF 'IBCO!(IBCO=2)
QUIT
+10 SET IBOK=1
End DoDot:1
IF 'IBOK
if IBCO=2
GOTO EXIT
GOTO 10
+11 ;
30 ; report or excel
+1 SET IBOUT=$$OUT^IBCNBOE
IF IBOUT=""
if $$STOP^IBCNINSU
GOTO EXIT
GOTO 109
+2 IF IBOUT="E"
WRITE !!,"To avoid undesired wrapping, please enter '0;256;999' at the 'DEVICE:' prompt.",!
+3 ;
+4 ; IB*702/DTG tweaked device prompt
DEV ;get the device
+1 NEW POP,ZTDESC,ZTRTN,ZTSAVE
+2 SET ZTRTN="RPT^IBCNBOA"
SET ZTDESC=IBHDR
SET ZTSAVE("IB*")=""
+3 DO EN^XUTMDEVQ(ZTRTN,ZTDESC,.ZTSAVE)
+4 IF POP
if $$STOP^IBCNINSU
GOTO EXIT
GOTO 30
+5 QUIT
+6 ;
11 ; starting month ; IB*702
+1 ;
+2 ; starting date
+3 SET IBCO=0
SET IBSTDT=$$IBSM("Beginning","")
+4 IF 'IBSTDT
if $$STOP^IBCNINSU
SET IBCO=2
QUIT
+5 SET IBBEGEX=$PIECE(IBSTDT,U,2)
SET IBSTDT=$PIECE(IBSTDT,U,1)
+6 SET IBBEG=IBSTDT_"01"
+7 ;
12 ; ending month ; IB*702
+1 ;
+2 WRITE !
+3 SET IBEDDT=$$IBSM("Ending",IBSTDT)
+4 SET IBBENEX=$PIECE(IBEDDT,U,2)
SET IBEDDT=$PIECE(IBEDDT,U,1)
+5 IF 'IBEDDT
if '$$STOP^IBCNINSU
GOTO 11
SET IBCO=2
QUIT
+6 SET IBEND=$$LAST^IBAGMM(IBEDDT)
+7 SET IBCO=1
+8 QUIT
+9 ;
21 ; starting date ; IB*702
+1 ;
+2 SET IBBEG=$$DATES^IBCNBOE("Beginning")
IF 'IBBEG
if $$STOP^IBCNINSU
SET IBCO=2
QUIT
+3 ;
22 ; ending date ; IB*702
+1 ;
+2 WRITE !
+3 SET IBEND=$$DATES^IBCNBOE("Ending",IBBEG)
IF 'IBEND
if '$$STOP^IBCNINSU
GOTO 21
SET IBCO=2
QUIT
+4 SET IBCO=1
+5 QUIT
+6 ;
IBSM(IBLABEL,IBSTDT) ; START/END MONTH ; IB*702
+1 ; IBLABEL - starting or ending month
+2 ; IBSTDT - starting month year in FM form
+3 ;
+4 NEW DIR,DIRUT,DUOUT,DTOUT,IBB,IBD,IBL,IBNDT,X,Y
+5 ;
+6 SET IBD=""
SET IBNDT=$SELECT(IBSTDT'="":IBSTDT,1:IBBUFSM)
SET IBB=$$EXMON($EXTRACT(IBNDT,1,5))
+7 IF $EXTRACT(IBLABEL,1,3)="Beg"
Begin DoDot:1
+8 WRITE !!,"Future dates are not allowed and the month selected cannot be later than"
+9 WRITE !,"the previous month."
+10 WRITE !,"The month selected must be a complete/full month. The current 'Month Year'"
+11 WRITE !,"of ("_IBCUR_") is not allowed.",!
End DoDot:1
IBSMA ; skip back tag
+1 SET DIR("?",1)="Enter the "_IBLABEL_" 'Month Year' for the range to be reported."
+2 SET DIR("?",2)="Use the Form 'MM YYYY' or '^' to Quit."
+3 SET DIR("?",3)="The month selected cannot be later than the previous month."
+4 SET DIR("?",4)="The month selected must be a complete/full month."
+5 SET DIR("?")="The current 'Month Year' of "_IBCUR_" is not allowed."
+6 SET DIR("A")=$GET(IBLABEL)_" Month Year (Ex. January 2021)"
+7 SET DIR(0)="DO^::EM"
+8 DO ^DIR
+9 IF Y=""
WRITE *7,!,"Please enter the "_IBLABEL_" Month Year or '^' to Quit.",!
GOTO IBSMA
+10 IF $DATA(DIRUT)!$DATA(DUOUT)!$DATA(DTOUT)
SET IBD=""
GOTO IBSMX
+11 SET IBD=$EXTRACT(Y,1,5)
IF IBD=""
GOTO IBSMX
+12 SET IBL=$GET(Y(0))
IF IBL=""
SET IBL=$EXTRACT(IBD,4,5)_" "_($EXTRACT(IBD,1,3)+1700)
+13 ; check range(s)
+14 IF IBD=IBCURFM
WRITE !,*7,"May Not Select current 'Month Year' "_IBCUR_".",!
GOTO IBSMA
+15 IF IBD>IBCURFM
WRITE !,*7,"Future Dates are not allowed.",!
GOTO IBSMA
+16 IF IBD<IBNDT
WRITE *7,!,"Month Year entered ("_IBL_") is less than minimum entry of ("_IBB_").",!
GOTO IBSMA
+17 SET IBD=IBD_U_IBL
+18 ;
IBSMX ; Exit subroutine
+1 QUIT IBD
+2 ;
EXMON(IBCHGDT) ; change FM year month to external 'month year'
+1 ;Input:
+2 ; IBCHGDT - year month of FM date (ex: 32107)
+3 ;
+4 IF IBCHGDT=""
QUIT ""
+5 QUIT $PIECE("JAN,FEB,MAR,APR,MAY,JUN,JUL,AUG,SEP,OCT,NOV,DEC",",",+$EXTRACT(IBCHGDT,4,5))_" "_($EXTRACT(IBCHGDT,1,3)+1700)
+6 ;
+7 ;
RPT ; run report
+1 ;IB*702/TAZ - New variables used during processing.
+2 NEW IBQUIT,ZTQUEUED,ZTSTOP
+3 ;
+4 SET IBQUIT=0
+5 ;
+6 ;Patch 305- QUIT in line below inserted for transmission to ARC
+7 DO SEARCH(IBBEG,IBEND,IBMONTH)
if $GET(IBARFLAG)
QUIT
if IBQUIT
GOTO EXIT
+8 DO PRINT(IBBEG,IBEND,IBOUT)
+9 ;
EXIT ; exit report
+1 KILL ^TMP($JOB)
+2 QUIT
+3 ;
SEARCH(IBBEG,IBEND,IBMONTH) ; search/sort statistics for activity report
+1 ;IB*702/DTG remove IBVER for 'verified' logic
+2 ; N IBXST,IBXDT,IBBUFDA,IBB0,IBSTAT,IBTIME,IBS3,IBDATE,IBVER,IBDT2 S IBQUIT=""
+3 NEW IBXST,IBXDT,IBBUFDA,IBB0,IBSTAT,IBTIME,IBS3,IBDATE,IBDT2
SET IBQUIT=""
+4 SET IBBEG=$GET(IBBEG)-.01
SET IBEND=$SELECT('$GET(IBEND):9999999,1:$PIECE(IBEND,".")+.9)
+5 ;
+6 SET IBXST=""
FOR
SET IBXST=$ORDER(^IBA(355.33,"AFST",IBXST))
if IBXST=""
QUIT
Begin DoDot:1
+7 SET IBXDT=+IBBEG
FOR
SET IBXDT=$ORDER(^IBA(355.33,"AFST",IBXST,IBXDT))
if 'IBXDT!(IBXDT>IBEND)
QUIT
Begin DoDot:2
+8 SET IBBUFDA=0
FOR
SET IBBUFDA=$ORDER(^IBA(355.33,"AFST",IBXST,IBXDT,IBBUFDA))
if 'IBBUFDA
QUIT
Begin DoDot:3
+9 ;
+10 ;IB*702/DTG remove Set IBVER for 'verified' logic
+11 ;S IBB0=$G(^IBA(355.33,IBBUFDA,0)),IBSTAT=$P(IBB0,U,4),IBVER=$P(IBB0,U,10)
+12 SET IBB0=$GET(^IBA(355.33,IBBUFDA,0))
SET IBSTAT=$PIECE(IBB0,U,4)
+13 ;
+14 ; entered
+15 IF IBXST="E"
SET IBDATE=+IBB0
IF +IBDATE
IF IBDATE>IBBEG
IF IBDATE<IBEND
Begin DoDot:4
+16 SET IBDT2=+$PIECE(IBB0,U,10)
IF 'IBDT2
SET IBDT2=+$PIECE(IBB0,U,5)
IF 'IBDT2
SET IBDT2=$$NOW^XLFDT
+17 SET IBTIME=+$$FMDIFF^XLFDT(IBDT2,IBDATE,2)
SET IBSTAT="ENTERED"
SET IBS3=1
+18 IF +$GET(IBMONTH)
DO SET(IBSTAT,$EXTRACT(IBDATE,1,5),IBS3,IBTIME,IBB0)
+19 DO SET(IBSTAT,99999,IBS3,IBTIME,IBB0)
End DoDot:4
+20 ;
+21 ;IB*702/DTG remove 'verified' logic
+22 ; verified
+23 ;I IBXST="V" S IBDATE=+$P(IBB0,U,10) I +IBDATE,IBDATE>IBBEG,IBDATE<IBEND D
+24 ;. ;S IBTIME=+$$FMDIFF^XLFDT(IBDATE,+IBB0,2),IBSTAT="VERIFIED",IBS3=2
+25 ;. ;I +$G(IBMONTH) D SET(IBSTAT,$E(IBDATE,1,5),IBS3,IBTIME,IBB0)
+26 ;. ;D SET(IBSTAT,99999,IBS3,IBTIME,IBB0)
+27 ;
+28 ; processed
+29 IF IBXST="A"!(IBXST="R")
SET IBDATE=+$PIECE(IBB0,U,5)
IF +IBDATE
IF IBDATE>IBBEG
IF IBDATE<IBEND
Begin DoDot:4
+30 SET IBDT2=+IBB0
+31 SET IBTIME=+$$FMDIFF^XLFDT(IBDATE,+IBDT2,2)
SET IBSTAT="UNKNOWN"
SET IBS3=6
+32 ;IB*702/DTG remove &V and V
+33 ;I $P(IBB0,U,4)="A" S IBS3=3,IBSTAT="ACCEPTED" I 'IBVER S IBS3=4,IBSTAT=IBSTAT_" (&V)"
+34 ;I $P(IBB0,U,4)="R" S IBS3=5,IBSTAT="REJECTED" I +IBVER S IBS3=6,IBSTAT=IBSTAT_" (V)"
+35 IF $PIECE(IBB0,U,4)="A"
SET IBS3=3
SET IBSTAT="ACCEPTED"
+36 IF $PIECE(IBB0,U,4)="R"
SET IBS3=5
SET IBSTAT="REJECTED"
+37 IF +$GET(IBMONTH)
DO SET(IBSTAT,$EXTRACT(IBDATE,1,5),IBS3,IBTIME,IBB0)
+38 DO SET(IBSTAT,99999,IBS3,IBTIME,IBB0)
End DoDot:4
End DoDot:3
End DoDot:2
SET IBQUIT=$$STOP
if IBQUIT
QUIT
End DoDot:1
if IBQUIT
QUIT
+39 ;
+40 QUIT
+41 ;
SET(STAT,S1,S3,TIME,IBB0) ;
+1 DO TMP("IBCNBOA",S1,1,S3,TIME,STAT)
+2 IF S3<3
DO TMP("IBCNBOA",S1,2,1,TIME,"NOT PROCESSED")
+3 IF S3>2
DO TMP("IBCNBOA",S1,2,2,TIME,"PROCESSED")
+4 DO TMP("IBCNBOA",S1,2,9,TIME,"TOTAL")
+5 ;
+6 if $EXTRACT(STAT)'="A"
QUIT
+7 ;
+8 DO TMP1("IBCNBOAC",S1,+$PIECE(IBB0,U,7),+$PIECE(IBB0,U,8),+$PIECE(IBB0,U,9))
+9 QUIT
+10 ;
TMP(XREF,S1,S2,S3,TIME,NAME) ;
+1 SET ^TMP($JOB,XREF,S1,S2,S3)=NAME
+2 SET ^TMP($JOB,XREF,S1,S2,S3,"CNT")=$GET(^TMP($JOB,XREF,S1,S2,S3,"CNT"))+1
+3 SET ^TMP($JOB,XREF,S1,S2,S3,"TM")=$GET(^TMP($JOB,XREF,S1,S2,S3,"TM"))+TIME
+4 IF '$GET(^TMP($JOB,XREF,S1,S2,S3,"HG"))!($GET(^TMP($JOB,XREF,S1,S2,S3,"HG"))<TIME)
SET ^TMP($JOB,XREF,S1,S2,S3,"HG")=TIME
+5 IF '$GET(^TMP($JOB,XREF,S1,S2,S3,"LS"))!($GET(^TMP($JOB,XREF,S1,S2,S3,"LS"))>TIME)
SET ^TMP($JOB,XREF,S1,S2,S3,"LS")=TIME
+6 ; IB*702/DTG start call to set stubs
+7 DO TMPCHK(XREF,S1,S2,S3,TIME,NAME)
+8 ; IB*702/DTG end call to set stubs
+9 QUIT
+10 ;
+11 ; IB*702/DTG start set stubs for item entries.
TMPCHK(XREF,S1,S2,S3,TIME,NAME) ; check if not there set stub for all if one is set
+1 ; use S1 (date), and S2 1 or 2
+2 NEW IBBI
+3 IF S2=1
FOR IBBI=1,3,5
IF $GET(^TMP($JOB,XREF,S1,S2,IBBI))=""
Begin DoDot:1
+4 SET ^TMP($JOB,XREF,S1,S2,IBBI)=$PIECE("ENTERED,VERIFIED,ACCEPTED,,REJECTED",",",IBBI)
+5 SET ^TMP($JOB,XREF,S1,S2,IBBI,"CNT")=""
+6 SET ^TMP($JOB,XREF,S1,S2,IBBI,"TM")=""
+7 IF $GET(^TMP($JOB,XREF,S1,S2,IBBI,"HG"))=""
SET ^TMP($JOB,XREF,S1,S2,IBBI,"HG")=""
+8 IF $GET(^TMP($JOB,XREF,S1,S2,IBBI,"LS"))=""
SET ^TMP($JOB,XREF,S1,S2,IBBI,"LS")=""
End DoDot:1
+9 IF S2=2
FOR IBBI=1,2,9
IF $GET(^TMP($JOB,XREF,S1,S2,IBBI))=""
Begin DoDot:1
+10 SET ^TMP($JOB,XREF,S1,S2,IBBI)=$PIECE("NOT PROCESSED,PROCESSED,,,,,,,TOTAL",",",IBBI)
+11 SET ^TMP($JOB,XREF,S1,S2,IBBI,"CNT")=""
+12 SET ^TMP($JOB,XREF,S1,S2,IBBI,"TM")=""
+13 IF $GET(^TMP($JOB,XREF,S1,S2,IBBI,"HG"))=""
SET ^TMP($JOB,XREF,S1,S2,IBBI,"HG")=""
+14 IF $GET(^TMP($JOB,XREF,S1,S2,IBBI,"LS"))=""
SET ^TMP($JOB,XREF,S1,S2,IBBI,"LS")=""
End DoDot:1
+15 QUIT
+16 ; IB*702/DTG end set stubs for item entries.
+17 ;
TMP1(XREF,S1,IC,GC,PC) ;
+1 IF +IC
SET ^TMP($JOB,XREF,S1,"I")=$GET(^TMP($JOB,XREF,S1,"I"))+1
+2 IF +GC
SET ^TMP($JOB,XREF,S1,"G")=$GET(^TMP($JOB,XREF,S1,"G"))+1
+3 IF +PC
SET ^TMP($JOB,XREF,S1,"P")=$GET(^TMP($JOB,XREF,S1,"P"))+1
+4 SET ^TMP($JOB,XREF,S1,"CNT")=$GET(^TMP($JOB,XREF,S1,"CNT"))+1
+5 QUIT
+6 ;
+7 ;
+8 ;
PRINT(IBBEG,IBEND,IBOUT) ;
+1 NEW IBXREF,IBLABLE,IBS1,IBS2,IBS3,IBINS,IBGRP,IBPOL,IBCNT,IBIP,IBGP,IBPP,IBRDT,IBPGN,IBRANGE,IBLN,IBI,IBHED
+2 ;
+3 IF "^R^E^"'[(U_$GET(IBOUT)_U)
SET IBOUT="R"
+4 SET IBRANGE=$SELECT(IBMONTH:IBBEGEX,1:$$FMTE^XLFDT(+IBBEG))_" - "_$SELECT(IBMONTH:IBBENEX,1:$$FMTE^XLFDT(IBEND))
+5 ;S IBRANGE=$$FMTE^XLFDT(+IBBEG)_" - "_$$FMTE^XLFDT(IBEND)
+6 SET IBRDT=$$FMTE^XLFDT($JUSTIFY($$NOW^XLFDT,0,4),2)
SET IBRDT=$TRANSLATE(IBRDT,"@"," ")
SET (IBLN,IBPGN)=0
+7 ; IB*702/DTG start Combine vars, no data check, end of report
+8 SET IBXREF="IBCNBOA"
SET IBS1=""
+9 SET IBHED=$SELECT(IBOUT="E":"PHDL",1:"HDR")
DO @IBHED
+10 IF '$DATA(^TMP($JOB,IBXREF))
Begin DoDot:1
+11 WRITE !
if $GET(IBOUT)="R"
WRITE ?23
WRITE "* * * N O D A T A F O U N D * * *",!
+12 DO EOR(80)
+13 SET IBI=$$PAUSE
End DoDot:1
QUIT
+14 ;
+15 ; Excel output
+16 IF IBOUT="E"
Begin DoDot:1
+17 FOR
SET IBS1=$ORDER(^TMP($JOB,IBXREF,IBS1))
if IBS1=""
DO EOR(132)
if IBS1=""
QUIT
Begin DoDot:2
+18 ;IB*702/DTG Moved pre-existing code to new function
DO GETLABL
+19 SET IBS2=0
FOR
SET IBS2=$ORDER(^TMP($JOB,IBXREF,IBS1,IBS2))
if IBS2=""
QUIT
Begin DoDot:3
+20 SET IBS3=""
FOR
SET IBS3=$ORDER(^TMP($JOB,IBXREF,IBS1,IBS2,IBS3))
if 'IBS3
QUIT
DO PRTLN
End DoDot:3
+21 ;
+22 ;IB*702/DTG Moved pre-existing code to new function
DO GETOAC
+23 WRITE U_IBINS_U_IBIP_"%"_U_IBGRP_U_IBGP_"%"_U_IBPOL_U_IBPP_"%"
End DoDot:2
End DoDot:1
SET IBI=$$PAUSE
QUIT
+24 ;
+25 FOR
SET IBS1=$ORDER(^TMP($JOB,IBXREF,IBS1))
if IBS1=""
DO EOR(80)
if IBS1=""
QUIT
if IBLN>(IOSL-17)
DO HDR
if IBQUIT
QUIT
Begin DoDot:1
+26 ;IB*702/DTG Moved pre-existing code to new function
DO GETLABL
+27 WRITE !,?(40-($LENGTH(IBLABLE)/2)),IBLABLE,!
+28 WRITE !,?43,"AVERAGE",?56,"LONGEST",?68,"SHORTEST"
+29 WRITE !,"STATUS",?22,"COUNT",?30,"PERCENT",?43,"# DAYS",?56,"# DAYS",?68,"# DAYS"
+30 ;
+31 SET IBS2=0
FOR
SET IBS2=$ORDER(^TMP($JOB,IBXREF,IBS1,IBS2))
if IBS2=""
QUIT
Begin DoDot:2
+32 WRITE !,"-----------------------------------------------------------------------------"
+33 SET IBS3=""
FOR
SET IBS3=$ORDER(^TMP($JOB,IBXREF,IBS1,IBS2,IBS3))
if 'IBS3
QUIT
DO PRTLN
SET IBLN=IBLN+1
End DoDot:2
SET IBLN=IBLN+1
+34 ;
+35 ;IB*702/DTG Moved pre-existing code to new function
DO GETOAC
+36 WRITE !!,?2,IBINS," New Compan",$SELECT(IBINS=1:"y",1:"ies")," (",IBIP,"%), "
+37 WRITE IBGRP," New Group/Plan",$SELECT(IBGRP=1:"",1:"s")," (",IBGP,"%), "
+38 WRITE IBPOL," New Patient Polic",$SELECT(IBPOL=1:"y",1:"ies")," (",IBPP,"%)",!
End DoDot:1
SET IBLN=IBLN+7
+39 ;
+40 ; IB*702/DTG end Combine vars, no data check, end of report
+41 ;
+42 IF 'IBQUIT
SET IBI=$$PAUSE
+43 QUIT
+44 ;
+45 ; IB*702/DTG start Combine parts for excel and report
+46 ;
GETLABL ; pick up common values for Excel and Report
+1 ;
+2 SET IBLABLE=$SELECT(IBS1=99999:"TOTALS",($EXTRACT(IBBEG,1,5)<IBS1)&($EXTRACT(IBEND,1,5)>IBS1):$$FMTE^XLFDT(IBS1_"00"),1:"")
+3 ;<
IF IBLABLE=""
Begin DoDot:1
+4 SET IBLABLE=$$FMTE^XLFDT($SELECT($EXTRACT(IBBEG,1,5)<IBS1:IBS1_"01",1:IBBEG))_" - "_$$FMTE^XLFDT($SELECT($EXTRACT(IBEND,1,5)>IBS1:$$SCH^XLFDT("1M(L)",IBS1_11),1:IBEND))
+5 IF $GET(IBMONTH)&(IBLABLE["-")
SET IBLABLE=$$FMTE^XLFDT(IBS1_"00")
End DoDot:1
+6 QUIT
+7 ;
GETOAC ; pick up items for IBCNBOAC
+1 ;
+2 SET IBINS=+$GET(^TMP($JOB,"IBCNBOAC",IBS1,"I"))
SET IBGRP=+$GET(^TMP($JOB,"IBCNBOAC",IBS1,"G"))
+3 SET IBPOL=+$GET(^TMP($JOB,"IBCNBOAC",IBS1,"P"))
SET IBCNT=+$GET(^TMP($JOB,"IBCNBOAC",IBS1,"CNT"))
+4 SET (IBIP,IBGP,IBPP)=0
IF IBCNT'=0
SET IBIP=((IBINS/IBCNT)*100)\1
SET IBGP=((IBGRP/IBCNT)*100)\1
SET IBPP=((IBPOL/IBCNT)*100)\1
+5 QUIT
+6 ;
EOR(IBLE) ; write end of report
+1 IF '$GET(IBLE)
SET IBLE=80
+2 WRITE !
if $GET(IBOUT)="R"
WRITE ?((IBLE\2)-10)
WRITE "*** END OF REPORT ***",!
+3 QUIT
+4 ;
EXN(IBBN) ; round number by .05 return with 1st decimal
+1 NEW IBBW,IBBX,IBBR
+2 SET IBBN=+$GET(IBBN)
+3 ;I IBBN="" Q ""
+4 SET IBBW=$SELECT($EXTRACT(IBBN,1)="-":"-",1:"")
+5 SET IBBX=IBBN+(IBBW_.05)
+6 if $PIECE(IBBX,".",1)=""
SET IBBX="0"_"."_$PIECE(IBBX,".",2)
+7 SET IBBR=$PIECE(IBBX,".",1)_"."_+($EXTRACT($PIECE(IBBX,".",2),1))
+8 QUIT IBBR
+9 ;
PRTLN ; IB*702/DTG Rewrote tag to print zeros for statuses with no counts
+1 NEW IBSTX,IBCNT,IBTM,IBHG,IBLS,IBTCNT
+2 ;IB*702 added variables
NEW IBBA,IBBC,IBBD
+3 ;
+4 SET IBSTX=$GET(^TMP($JOB,IBXREF,IBS1,IBS2,IBS3))
+5 ;S IBCNT=$G(^TMP($J,IBXREF,IBS1,IBS2,IBS3,"CNT")) Q:'IBCNT ;IB*702 removed quit
+6 SET IBCNT=$GET(^TMP($JOB,IBXREF,IBS1,IBS2,IBS3,"CNT"))
+7 SET IBTM=$GET(^TMP($JOB,IBXREF,IBS1,IBS2,IBS3,"TM"))
+8 SET IBHG=$GET(^TMP($JOB,IBXREF,IBS1,IBS2,IBS3,"HG"))
+9 SET IBLS=$GET(^TMP($JOB,IBXREF,IBS1,IBS2,IBS3,"LS"))
+10 ;S IBTCNT=$G(^TMP($J,IBXREF,IBS1,2,9,"CNT")) Q:'IBTCNT ;IB*702 removed quit
+11 SET IBTCNT=$GET(^TMP($JOB,IBXREF,IBS1,2,9,"CNT"))
+12 ;
+13 ; Excel output
+14 IF IBOUT="E"
Begin DoDot:1
+15 WRITE !,IBLABLE_U_IBSTX_U_$FNUMBER(IBCNT,",")_U
+16 SET IBBA=$SELECT((IBCNT'=""&(IBTCNT'="")):((IBCNT/IBTCNT)*100),1:0)
SET IBBC=$$EXN(IBBA)
WRITE IBBC_"%"_U
+17 SET IBBA=$SELECT(IBCNT'="":$$STD((IBTM/IBCNT)),1:0)
SET IBBC=$$EXN(IBBA)
WRITE IBBC_U
+18 SET IBBA=$$STD(IBHG)
SET IBBC=$$EXN(IBBA)
WRITE IBBC_U
+19 SET IBBA=$$STD(IBLS)
SET IBBC=$$EXN(IBBA)
WRITE IBBC
End DoDot:1
QUIT
+20 ;
+21 ; Report output
+22 WRITE !,IBSTX,?20,$JUSTIFY($FNUMBER(IBCNT,","),7)
+23 SET IBBA=$SELECT((IBCNT'=""&(IBTCNT'="")):((IBCNT/IBTCNT)*100),1:0)
WRITE ?30,$JUSTIFY(IBBA,6,1),"%"
+24 SET IBBA=$SELECT(IBCNT'="":$$STD((IBTM/IBCNT)),1:0)
WRITE ?43,$JUSTIFY(IBBA,6,1)
+25 WRITE ?56,$JUSTIFY($$STD(IBHG),6,1),?68,$JUSTIFY($$STD(IBLS),6,1)
+26 QUIT
+27 ;
STD(SEC) ; convert seconds to days
+1 NEW IBX,IBD,IBS,IBH,DAYS
SET DAYS=""
if '$GET(SEC)
GOTO STDQ
+2 SET IBD=(SEC/86400)
SET IBD=+$PIECE(IBD,".")
+3 SET IBS=SEC-(IBD*86400)
+4 SET IBH=((IBS/60)/60)
SET IBH=+$JUSTIFY(IBH,0,2)
+5 SET DAYS=IBD+(IBH/24)
STDQ QUIT DAYS
+1 ;
HDR ;print the report header
+1 NEW RM
+2 SET IBQUIT=$$STOP
if IBQUIT
QUIT
+3 IF IBPGN>0
SET IBQUIT=$$PAUSE
if IBQUIT
QUIT
+4 SET RM=$SELECT(IBOUT="R":80,1:IOM)
+5 SET IBPGN=IBPGN+1
SET IBLN=4
IF IBPGN>1!($EXTRACT(IOST,1,2)["C-")
WRITE @IOF
+6 WRITE !,"INS BUFFER ACTIVITY REPORT ",IBRANGE," "
+7 WRITE ?(RM-22),IBRDT,?(RM-(6+$LENGTH(IBPGN)))," PAGE ",IBPGN,!
+8 SET IBI=""
SET $PIECE(IBI,"-",RM+1)=""
WRITE IBI,!
+9 QUIT
+10 ;
PHDL ; - Print the header line for the Excel spreadsheet
+1 ;IB*702/TAZ - Cleaned up code
+2 ; IB*602/HN ; Add report headers to Excel Spreadsheets
+3 WRITE !,"INS BUFFER ACTIVITY REPORT^",IBRANGE_"^"_$$FMTE^XLFDT($$NOW^XLFDT,1),!
+4 ; IB*602/HN end
+5 WRITE "MONTH^STATUS^COUNT^PERCENT^AVERAGE # DAYS^LONGEST # DAYS^SHORTEST # DAYS^New Companies^% New Companies^New Group/Plans^% New Group/Plans^New Patient Policies^% New Patient Policies"
+6 QUIT
+7 ;
PAUSE() ;pause at end of screen if being displayed on a terminal
+1 NEW IBX,DIRUT,DUOUT,DTOUT,X,Y
+2 SET IBX=0
+3 IF $EXTRACT(IOST,1,2)["C-"
WRITE !!
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)!($DATA(DIRUT))
SET IBX=1
+4 QUIT IBX
+5 ;
STOP() ;determine if user has requested the queued report to stop
+1 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET ZTSTOP=1
KILL ZTREQ
IF +$GET(IBPGN)
WRITE !,"***TASK STOPPED BY USER***"
+2 QUIT +$GET(ZTSTOP)
+3 ;
IBAR(IBBEG,IBEND) ;Entry point for Vista IB AR data to ARC
+1 ;patch 305 - called by IBRFN4
+2 NEW IBMONTH,IBARFLAG,IBARDATA,IBTM,IBCNT
+3 SET IBMONTH=0
SET IBARFLAG=1
KILL ^TMP($JOB)
+4 DO RPT
+5 SET IBTM=$GET(^TMP($JOB,"IBCNBOA",99999,2,2,"TM"))
+6 SET IBCNT=$GET(^TMP($JOB,"IBCNBOA",99999,2,2,"CNT"))
+7 IF 'IBCNT
SET IBARDATA=0
GOTO IBARQ
+8 SET IBARDATA=$FNUMBER($$STD((IBTM/IBCNT)),"",1)
+9 KILL ^TMP($JOB)
IBARQ QUIT IBARDATA
+1 ;
