IBOHLS2 ;ALB/BAA - IB HELD CHARGES LIST MANAGER ;08-SEP-2015
;;2.0;INTEGRATED BILLING;**554**;21-MAR-94;Build 81
;Per VA Directive 6402, this routine should not be modified.
;
REL ; release selected copay charges
D FULL^VALM1
N I,J,IBXX,VALMY,IBND,DATA,NAME,CNT,DFN,IBCHRGS,RELCPY
S RELCPY=""
;
;
D EN^VALM2($G(XQORNOD(0)))
I $D(VALMY) S IBXX=0 F S IBXX=$O(VALMY(IBXX)) Q:'IBXX D
. S DATA=$G(^TMP($J,"IBOHLSX",IBXX))
. S DFN=$P(DATA,U,1)
. S NAME=$P(DATA,U,2)
. S CNT=$P(DATA,U,3)
. S DATA=^TMP($J,"IBOHLS",NAME,CNT,"IBND")
. S IBND=$P(DATA,U,3)
. S IBCHRGS=^TMP($J,"IBOHLS",NAME,CNT)
. Q:IBND="" D RELHLD(DFN,IBND,IBCHRGS)
. I RELCPY=1 K ^TMP($J,"IBOHLS",NAME,CNT)
;
D BLD^IBOHLS
S VALMBCK="R"
Q
;
RELHLD(DFN,IBN,IB0) ; queue copay for release
K IBR60
K ^TMP($J,"IBHOLD")
I '$$KCHK^XUSRB("IB AUTHORIZE") D G RELHLDQ
. W !?5,"The necessary key is IB AUTHORIZE. Please see your manager." ;
. D PAUSE^VALM1
;
W !," Copay for "_$P(IB0,U,1)_" - "_$P(IB0,U,2)_" for the amount of $"_$P(IB0,U,7)_" will be released."
;
S DIR(0)="Y",DIR("A")="Are you sure you want to Release this Copay",DIR("B")="NO"
S DIR("?",1)=" Enter: 'Y' - to Release the Copay"
S DIR("?",2)=" 'N' - to NOT Release the Copay"
S DIR("?",3)=" '^' - to exit this option"
D ^DIR K DIR
I Y'=1 D Q
. S RELCPY=0
. W !," Release of Copay for "_$P(IB0,U,1)_" - "_$P(IB0,U,2)_" canceled."
. D PAUSE^VALM1
;
S ^TMP($J,"IBHOLD",DFN,IBN)=""
;
D REL^IBOHRL ; Release charges
;
W !," Copay for "_$P(IB0,U,1)_" - "_$P(IB0,U,2)_" for the amount of $"_$P(IB0,U,7)_" has been queued for released."
S RELCPY=1
D PAUSE^VALM1
K ^TMP($J,"IBHOLD")
RELHLDQ Q ;
;
RPT(RTN,FILTERS) ; print the information
N BDATE,EDATE
S BDATE=$P(FILTERS(0),U,1),EDATE=$P(FILTERS(0),U,2)
D DEVICE("PR")
D PAUSE^VALM1
D BLD^IBOHLS
S VALMBCK="R" Q
Q
;
DEVICE(TYPE) ; Ask user to select device
;
D CLEAR^VALM1
D FULL^VALM1
N %ZIS,CRT,MAXCNT,POP
S %ZIS="QM" D ^%ZIS G:POP ENQ
; print report
I IOST["C-" S MAXCNT=IOSL-3,CRT=1
E S MAXCNT=IOSL,CRT=0
I $D(IO("Q")) D G ENQ
.S ZTDESC="VistA Held Charges Report"
.S ZTRTN="QUE^IBOHLS2",ZTDESC="IB - COPAYS ON HOLD"
.S (IBDIVS,V)="" F S V=$O(FILTERS(1,V)) Q:V="" S IBDIVS=IBDIVS_$S(IBDIVS="":"",1:",")_V
.S (WHO,V)="" F S V=$O(FILTERS(1,V)) Q:V="" S WHO=WHO_$S(WHO="":"",1:",")_V
.S ZTIO=ION_";"_IOST_";"_IOM_";"_IOSL
.F I="CRT","TYPE","MAXCNT","FILTERS(" S ZTSAVE(I)=""
.D ^%ZTLOAD K IO("Q") D HOME^%ZIS
.W !!,$S($D(ZTSK):"This job has been queued as task #"_ZTSK_".",1:"Unable to queue this job.")
.K ZTSK,IO("Q")
;
;
I TYPE="PR" U IO D PRINT("IBOHLS",BDATE,EDATE,MAXCNT)
I TYPE="EF" U IO D EXCEL("IBOHLS",BDATE,EDATE,MAXCNT)
;
D ^%ZISC
;
I $D(ZTQUEUED) S ZTREQ="@"
K ^TMP("IBOUT",$J)
;
ENQ Q
;
PRINT(RTN,BDATE,EDATE,MAX) ; -- print the current data
N REC,CNT,LCNT,RX,IBQUIT,FIRST,XX,NAME,LINE,ZZ,ZZ1,ZZ2,PGC,RNB
S LCNT=0,PGC=0,IBQUIT=0
D CLEAR^VALM1
U IO
D HEADER
S NAME="" F S NAME=$O(^TMP($J,"IBOHLS",NAME)) Q:NAME="" D
. S FIRST=1
. S CNT=0 F S CNT=$O(^TMP($J,"IBOHLS",NAME,CNT)) Q:CNT="" D
.. D:$Y>MAX HEADER Q:IBQUIT
.. S LINE=$$SETL("","","",1,2) ;line#
.. ;PATNAME^PATID^TYPE^FROM/FILL DATE^TO/RLS DATE^#DAYS ON HOLD^CHARGE
.. S REC=^TMP($J,"IBOHLS",NAME,CNT)
.. S LINE=$$SETL(LINE,$P(REC,U),"",4,22)
.. S LINE=$$SETL(LINE,$P(REC,U,2),"",26,6)
.. S LINE=$$SETL(LINE,$P(REC,U,3),"",35,6)
.. S LINE=$$SETL(LINE,$$FMTE^XLFDT($P(REC,U,4),"2DZ"),"",44,8)
.. S LINE=$$SETL(LINE,$$FMTE^XLFDT($P(REC,U,5),"2DZ"),"",54,8)
.. S LINE=$$SETL(LINE,$P(REC,U,6),"",63,5)
.. S LINE=$$SETL(LINE,$J($P(REC,U,7),8,2),"",71,8)
.. S LCNT=LCNT+1
.. S ^TMP("IBOUT",$J,LCNT)=LINE
.. I $D(^TMP($J,"IBOHLS",NAME,CNT,1)) S RX=^(1),RX="Rx#:"_RX D
... ;RX VALUE
... S LINE=$$SETL("",RX,"",37,20)
... S LCNT=LCNT+1
... S ^TMP("IBOUT",$J,LCNT)=LINE
.. I $D(^TMP($J,"IBOHLS",NAME,CNT,2)) D
... ;BILL#AR STATUS^DATE BILLED^CHARGE
... S BCNT=0 F S BCNT=$O(^TMP($J,"IBOHLS",NAME,CNT,2,BCNT)) Q:BCNT="" D
.... S REC=^TMP($J,"IBOHLS",NAME,CNT,2,BCNT)
.... S LINE=$$SETL("","Bill: ","",6,18)
.... S LINE=$$SETL(LINE,$P(REC,U),"",15,10)
.... S LINE=$$SETL(LINE,$P(REC,U,2),"",26,10)
.... S LINE=$$SETL(LINE,$$FMTE^XLFDT($P(REC,U,3),"2DZ"),"",39,8)
.... S LINE=$$SETL(LINE,$J($P(REC,U,4),8,2),"",48,11)
.... S LCNT=LCNT+1
.... S ^TMP("IBOUT",$J,LCNT)=LINE
.... S RNB=$P(REC,U,7)
.... I RNB'="" D
..... S LINE=$$SETL("","RNB: ","",6,6)
..... S LINE=$$SETL(LINE,RNB,"",14,60)
.. I $D(^TMP($J,"IBOHLS",NAME,CNT,3)),FIRST D ; IF DISPLAYING INSURANCE INFORMATION
... N ZZ,ZZ1,ZZ2
... ;ins co^sub id^plan id^effective dt^expiration
... S FIRST=0
... S LINE=$$SETL("","Insurance","",8,9)
... S LINE=$$SETL(LINE,"Subscriber","",28,10)
... S LINE=$$SETL(LINE,"Group","",44,5)
... S LINE=$$SETL(LINE,"Eff Dt","",54,6)
... S LINE=$$SETL(LINE,"Exp Dt","",66,6)
... S LCNT=LCNT+1
... S ^TMP("IBOUT",$J,LCNT)=LINE
... S LCNT=LCNT+1
... S $P(ZZ2,"-",68)=""
... S LINE=$$SETL("",ZZ2,"",8,68)
... S ^TMP("IBOUT",$J,LCNT)=LINE
... S ZZ=0 F S ZZ=$O(^TMP($J,"IBOHLS INS",NAME,ZZ)) Q:ZZ="" D
.... ;plan coverage^effective date^covered?^limit
.... S ZZ1=^TMP($J,"IBOHLS INS",NAME,ZZ)
.... S LINE=$$SETL("",$P(ZZ1,U),"",8,15)
.... S LINE=$$SETL(LINE,$P(ZZ1,U,2),"",28,10)
.... S LINE=$$SETL(LINE,$P(ZZ1,U,3),"",44,6)
.... S LINE=$$SETL(LINE,$$FMTE^XLFDT($P(ZZ1,U,4),"2DZ"),"",54,8)
.... S LINE=$$SETL(LINE,$$FMTE^XLFDT($P(ZZ1,U,5),"2DZ"),"",66,8)
.... S LCNT=LCNT+1
.... S ^TMP("IBOUT",$J,LCNT)=LINE
.... S LINE=$$SETL("","Plan Coverage Effective Date Covered? Limit Comments","",10,60)
.... S LCNT=LCNT+1
.... S ^TMP("IBOUT",$J,LCNT)=LINE
.... S ZZ2=0 F S ZZ2=$O(^TMP($J,"IBOHLS INS",NAME,ZZ,ZZ2)) Q:ZZ2="" D
..... S ZZ1=^TMP($J,"IBOHLS INS",NAME,ZZ,ZZ2)
..... S LINE=$$SETL("",$P(ZZ1,U),"",10,15)
..... S LINE=$$SETL(LINE,$$FMTE^XLFDT($P(ZZ2,U,2),"2DZ"),"",28,8)
..... S LINE=$$SETL(LINE,$P(ZZ1,U,3),"",46,10)
..... S LINE=$$SETL(LINE,$P(ZZ1,U,4),"",59,20)
..... S LCNT=LCNT+1
..... S ^TMP("IBOUT",$J,LCNT)=LINE
;
S XX=0
F S XX=$O(^TMP("IBOUT",$J,XX)) Q:XX="" D:$Y>MAX HEADER Q:IBQUIT W !,^TMP("IBOUT",$J,XX)
W !!,?5,"END OF REPORT"
Q
;
N DIR,X,Y,DTOUT,DUOUT,OFFSET,HDR,DASHES,DASHES2,LIN,IBPXT
S IBPXT=0
;
I CRT,PGC>0,'$D(ZTQUEUED) D I IBPXT G HEADERX
. I MAX<51 F LIN=1:1:(MAX-$Y) W !
. S DIR(0)="E" D ^DIR K DIR
. I X="^" S IBQUIT=1
. I $D(DTOUT)!$D(DUOUT)!(IBQUIT) S IBPXT=1 Q
I $D(ZTQUEUED),$$S^%ZTLOAD() S (ZTSTOP,IBPXT)=1 G HEADERX
S PGC=PGC+1
W @IOF,!,?1,"VistA Held Charges Report"
S HDR=$$FMTE^XLFDT($$NOW^XLFDT,1)_" Page: "_PGC
S OFFSET=78-$L(HDR)
W ?OFFSET,HDR
I BDATE=0 S BDATE="Beginning"
I BDATE>0 S BDATE=$$FMTE^XLFDT(BDATE,"5Z")
S HDR=BDATE_" - "_$$FMTE^XLFDT(EDATE,"5Z")
S OFFSET=80-$L(HDR)\2
W !,?OFFSET,HDR
W !,?4,"Patient Name",?26,"ID",?35,"Type",?44,"Fr/Fl Dt",?54,"To/Rls Dt",?64,"Days",?73,"Amount"
W !,?2,"-----------------------------------------------------------------------------"
Q
;
EXPORT(RTN,FILTERS) ; -- print excel spreadsheet.
N REC,CNT,RX,IBQUIT,BDATE,EDATE,NAME
S LCNT=0,PGC=0,IBQUIT=0
S BDATE=$P(FILTERS(0),U,1),EDATE=$P(FILTERS(0),U,2)
D ^%ZISC
D DEVICE("EF")
;
D BLD^IBOHLS
D PAUSE
S VALMBCK="R"
Q
;
EXCEL(RTN,BDATE,EDATE,MAX) ; print the data in excel format
U IO
N LINE,LCNT,PCE,REC,OUT,NAME,XX,BCNT,CNT,NXT,ZZ,ZZ1,ZZ2,OUT
D EXHDR
S LCNT=0
S NAME="" F S NAME=$O(^TMP($J,"IBOHLS",NAME)) Q:NAME="" D COUNT
;
S XX=0
F S XX=$O(^TMP("IBOUT",$J,XX)) Q:XX="" W !,^TMP("IBOUT",$J,XX)
;
W !,"END OF REPORT"
D PAUSE
Q
;
COUNT ; format output
N LINE,REC,REC1
S FIRST=1,CNT=0,LINE=""
F S CNT=$O(^TMP($J,"IBOHLS",NAME,CNT)) Q:CNT="" D
. S LCNT=LCNT+1
. S REC=^TMP($J,"IBOHLS",NAME,CNT)
. ;PATNAME^PATID^TYPE^Fr/Fl D^To/Rls^#Days On Hold^CHARGE $ Fr/Fl Dt and To/Rls
. S $P(REC,U,4)=$$FMTE^XLFDT($P(REC,U,4),"2DZ")
. S $P(REC,U,5)=$$FMTE^XLFDT($P(REC,U,5),"2DZ")
. S ^TMP("IBOUT",$J,LCNT)=REC
. ;RX VALUE
. I $D(^TMP($J,"IBOHLS",NAME,CNT,1)) S $P(^TMP("IBOUT",$J,LCNT),U,8)=^TMP($J,"IBOHLS",NAME,CNT,1)
. I $D(^TMP($J,"IBOHLS",NAME,CNT,2)) D
.. S SVRC=^TMP("IBOUT",$J,LCNT),REC="",XX=0
.. S BCNT=0 F S BCNT=$O(^TMP($J,"IBOHLS",NAME,CNT,2,BCNT)) Q:BCNT="" D
... ;BILL#^AR STATUS^DATE BILLED^CHARGE
... S LINE=SVRC
... S REC=$P(^TMP($J,"IBOHLS",NAME,CNT,2,BCNT),U,1,6)
... S $P(REC,U,3)=$$FMTE^XLFDT($P(REC,U,3),"2DZ")
... S REC1=$P(REC,U,1,3)_U_$P(REC,U,6)
... S XX=XX+1
... I XX=1 S $P(^TMP("IBOUT",$J,LCNT),U,9)=REC1
... I XX>1 S LCNT=LCNT+1 S $P(LINE,U,9)=REC1,^TMP("IBOUT",$J,LCNT)=LINE,LINE=""
Q ;DON'T USE INSURANCE INFO. IT WILL BE TOO LONG.
;
EXHDR ; -- excel header
S HDR="Patient Name"_U_"ID"_U_"Type"_U_"Fr/Fl Dt"_U_"To/Rls Dt"_U_"Days"_U_"Amount"_U_"RX"_U_"BILL"_U_"AR STATUS"_U_"DATE BILLED"_U_"CHARGE"
W !,HDR
Q
;
PAUSE ;pause at end of screen if being displayed on a terminal
Q:$E(IOST,1,2)'["C-" N DIR,DUOUT,DTOUT,DIRUT W !
S DIR(0)="E" D ^DIR K DIR
I $D(DUOUT)!($D(DIRUT)) S IBQUIT=1
Q
;
PATINS ; view patient insurance
D FULL^VALM1
N I,J,IBXX,VALMY,ECNT,DFN,GOPAT
D EN^VALM2($G(XQORNOD(0)))
I $D(VALMY) S IBXX=0 F S IBXX=$O(VALMY(IBXX)) Q:'IBXX D
. S REC=$G(^TMP($J,"IBOHLSX",IBXX))
. S DFN=$P(REC,U,1)
. D EN^VALM("IBCNS VIEW PAT INS")
D BLD^IBOHLS
S VALMBCK="R"
Q
;
CLMTRK ; look at claims tracking
D FULL^VALM1
N I,J,IBXX,VALMY,ECNT,NAME,GOTPAT,RC,IBFR,IBTO
D EN^VALM2($G(XQORNOD(0)))
K ^TMP($J,"IBOHLS CLMTRK")
I $D(VALMY) S IBXX=0 F S IBXX=$O(VALMY(IBXX)) Q:'IBXX D
. S RC=$G(^TMP($J,"IBOHLSX",IBXX))
. S DFN=$P(RC,U,1),NAME=$P(RC,U,2),ECNT=$P(RC,U,3),GOTPAT=1
. S RC=^TMP($J,"IBOHLSF")
. S IBFR=$P(RC,U,1),IBTO=$P(RC,U,2)
. S ^TMP($J,"IBCLMTRK")=DFN_U_IBFR_U_IBTO
.D EN^VALM("IBT CLAIMS TRACKING EDITOR")
K ^TMP($J,"IBOHLS CLMTRK")
D BLD^IBOHLS
S VALMBCK="R"
Q
;
PATCLM ; look at claims INFO
D FULL^VALM1
N IBXX,VALMY,ECNT,PNAME,RC,XX,IBIFN
D EN^VALM2($G(XQORNOD(0)))
I $D(VALMY) S IBXX=0 F S IBXX=$O(VALMY(IBXX)) Q:'IBXX D
. S RC=$G(^TMP($J,"IBOHLSX",IBXX))
. S DFN=$P(RC,U,1),NAME=$P(RC,U,2),ECNT=$P(RC,U,3)
. D EN^VALM("IBJT ACTIVE LIST")
D BLD^IBOHLS
S VALMBCK="R"
Q
;
PATACP ; look at ACCOUNT PROFILE
D FULL^VALM1
N IBXX,VALMY,ECNT,NAME,RC,DFN,CPY,PRCATY
D EN^VALM2($G(XQORNOD(0)))
D CLEAR^VALM1
I $D(VALMY) S IBXX=0 F S IBXX=$O(VALMY(IBXX)) Q:'IBXX D
. S RC=$G(^TMP($J,"IBOHLSX",IBXX))
. S DFN=$P(RC,U,1),NAME=$P(RC,U,2),ECNT=$P(RC,U,3)
. N DIC,X,Y,DEBT,PRCADB,DA,PRCA,COUNT,OUT,SEL,BILL,BAT,TRAN,DR,DXS,DTOUT,DIROUT,DIRUT,DUOUT
. N DPTNOFZY,DPTNOFZK S (DPTNOFZY,DPTNOFZK)=1
. S COUNT=0,CPY=1
. S PRCATY="ALL",X=NAME
. S X=$$UPPER^VALM1(X)
. S Y=$S($O(^PRCA(430,"B",X,0)):$O(^(0)),$O(^PRCA(430,"D",X,0)):$O(^(0)),1:-1)
. I Y>0 S DEBT=$P($G(^PRCA(430,Y,0)),"^",9) I DEBT S PRCADB=$P($G(^RCD(340,DEBT,0)),"^"),^DISV(DUZ,"^PRCA(430,")=Y,$P(DEBT,"^",2)=$$NAM^RCFN01(DEBT) D COMP^PRCAAPR,EN1^PRCAATR(Y) Q
. S DIC="^RCD(340,",DIC(0)="E" D ^DIC
. I Y<0 W !,"No entries found for "_NAME Q
. S ^DISV(DUZ,"^RCD(340,")=+Y
. S PRCADB=$P(Y,"^",2),DEBT=+Y_"^"_$P(@("^"_$P(PRCADB,";",2)_+PRCADB_",0)"),"^")
. D COMP^PRCAAPR,HDR^PRCAAPR1,HDR2^PRCAAPR1,DIS^PRCAAPR1
. D PAUSE^VALM1
K ^TMP("PRCAAPR",$J)
D BLD^IBOHLS
S VALMBCK="R"
Q
;
SETL(LINE,DATA,LABEL,COL,LNG) ; Creates a line of data to be set into the body
; of the worklist
; Input: LINE - Current line being created
; DATA - Information to be added to the end of the current line
; LABEL - Label to describe the information being added
; COL - Column position in line to add information add
; LNG - Maximum length of data information to include on the line
; Returns: Line updated with added information
S LINE=LINE_$J("",(COL-$L(LABEL)-$L(LINE)))_LABEL_$E(DATA,1,LNG)
Q LINE
;
QUE ; QUEUED REPORT ENTRY
;Required variable input: FILTERS(0),FILTERS(1),FILTERS(2),BDATE,EDATE,INSTS,PATS,IINS,CRT,TYPE
;
D FULL^VALM1
D CLEAR^VALM1
S BDATE=$P(FILTERS(0),U,1),EDATE=$P(FILTERS(0),U,2)
S INSTS=$P(FILTERS(0),U,3),PATS=$P(FILTERS(0),U,4)
S IINS=FILTERS(3)
D SORT^IBOHLS1
;
I TYPE="PR" U IO D PRINT("IBOHLS",BDATE,EDATE,MAXCNT)
I TYPE="EF" U IO D EXCEL("IBOHLS",BDATE,EDATE,MAXCNT)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBOHLS2 12543 printed Apr 09, 2024@21:20:42 Page 2
IBOHLS2 ;ALB/BAA - IB HELD CHARGES LIST MANAGER ;08-SEP-2015
+1 ;;2.0;INTEGRATED BILLING;**554**;21-MAR-94;Build 81
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
REL ; release selected copay charges
+1 DO FULL^VALM1
+2 NEW I,J,IBXX,VALMY,IBND,DATA,NAME,CNT,DFN,IBCHRGS,RELCPY
+3 SET RELCPY=""
+4 ;
+5 ;
+6 DO EN^VALM2($GET(XQORNOD(0)))
+7 IF $DATA(VALMY)
SET IBXX=0
FOR
SET IBXX=$ORDER(VALMY(IBXX))
if 'IBXX
QUIT
Begin DoDot:1
+8 SET DATA=$GET(^TMP($JOB,"IBOHLSX",IBXX))
+9 SET DFN=$PIECE(DATA,U,1)
+10 SET NAME=$PIECE(DATA,U,2)
+11 SET CNT=$PIECE(DATA,U,3)
+12 SET DATA=^TMP($JOB,"IBOHLS",NAME,CNT,"IBND")
+13 SET IBND=$PIECE(DATA,U,3)
+14 SET IBCHRGS=^TMP($JOB,"IBOHLS",NAME,CNT)
+15 if IBND=""
QUIT
DO RELHLD(DFN,IBND,IBCHRGS)
+16 IF RELCPY=1
KILL ^TMP($JOB,"IBOHLS",NAME,CNT)
End DoDot:1
+17 ;
+18 DO BLD^IBOHLS
+19 SET VALMBCK="R"
+20 QUIT
+21 ;
RELHLD(DFN,IBN,IB0) ; queue copay for release
+1 KILL IBR60
+2 KILL ^TMP($JOB,"IBHOLD")
+3 IF '$$KCHK^XUSRB("IB AUTHORIZE")
Begin DoDot:1
+4 ;
WRITE !?5,"The necessary key is IB AUTHORIZE. Please see your manager."
+5 DO PAUSE^VALM1
End DoDot:1
GOTO RELHLDQ
+6 ;
+7 WRITE !," Copay for "_$PIECE(IB0,U,1)_" - "_$PIECE(IB0,U,2)_" for the amount of $"_$PIECE(IB0,U,7)_" will be released."
+8 ;
+9 SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to Release this Copay"
SET DIR("B")="NO"
+10 SET DIR("?",1)=" Enter: 'Y' - to Release the Copay"
+11 SET DIR("?",2)=" 'N' - to NOT Release the Copay"
+12 SET DIR("?",3)=" '^' - to exit this option"
+13 DO ^DIR
KILL DIR
+14 IF Y'=1
Begin DoDot:1
+15 SET RELCPY=0
+16 WRITE !," Release of Copay for "_$PIECE(IB0,U,1)_" - "_$PIECE(IB0,U,2)_" canceled."
+17 DO PAUSE^VALM1
End DoDot:1
QUIT
+18 ;
+19 SET ^TMP($JOB,"IBHOLD",DFN,IBN)=""
+20 ;
+21 ; Release charges
DO REL^IBOHRL
+22 ;
+23 WRITE !," Copay for "_$PIECE(IB0,U,1)_" - "_$PIECE(IB0,U,2)_" for the amount of $"_$PIECE(IB0,U,7)_" has been queued for released."
+24 SET RELCPY=1
+25 DO PAUSE^VALM1
+26 KILL ^TMP($JOB,"IBHOLD")
RELHLDQ ;
QUIT
+1 ;
RPT(RTN,FILTERS) ; print the information
+1 NEW BDATE,EDATE
+2 SET BDATE=$PIECE(FILTERS(0),U,1)
SET EDATE=$PIECE(FILTERS(0),U,2)
+3 DO DEVICE("PR")
+4 DO PAUSE^VALM1
+5 DO BLD^IBOHLS
+6 SET VALMBCK="R"
QUIT
+7 QUIT
+8 ;
DEVICE(TYPE) ; Ask user to select device
+1 ;
+2 DO CLEAR^VALM1
+3 DO FULL^VALM1
+4 NEW %ZIS,CRT,MAXCNT,POP
+5 SET %ZIS="QM"
DO ^%ZIS
if POP
GOTO ENQ
+6 ; print report
+7 IF IOST["C-"
SET MAXCNT=IOSL-3
SET CRT=1
+8 IF '$TEST
SET MAXCNT=IOSL
SET CRT=0
+9 IF $DATA(IO("Q"))
Begin DoDot:1
+10 SET ZTDESC="VistA Held Charges Report"
+11 SET ZTRTN="QUE^IBOHLS2"
SET ZTDESC="IB - COPAYS ON HOLD"
+12 SET (IBDIVS,V)=""
FOR
SET V=$ORDER(FILTERS(1,V))
if V=""
QUIT
SET IBDIVS=IBDIVS_$SELECT(IBDIVS="":"",1:",")_V
+13 SET (WHO,V)=""
FOR
SET V=$ORDER(FILTERS(1,V))
if V=""
QUIT
SET WHO=WHO_$SELECT(WHO="":"",1:",")_V
+14 SET ZTIO=ION_";"_IOST_";"_IOM_";"_IOSL
+15 FOR I="CRT","TYPE","MAXCNT","FILTERS("
SET ZTSAVE(I)=""
+16 DO ^%ZTLOAD
KILL IO("Q")
DO HOME^%ZIS
+17 WRITE !!,$SELECT($DATA(ZTSK):"This job has been queued as task #"_ZTSK_".",1:"Unable to queue this job.")
+18 KILL ZTSK,IO("Q")
End DoDot:1
GOTO ENQ
+19 ;
+20 ;
+21 IF TYPE="PR"
USE IO
DO PRINT("IBOHLS",BDATE,EDATE,MAXCNT)
+22 IF TYPE="EF"
USE IO
DO EXCEL("IBOHLS",BDATE,EDATE,MAXCNT)
+23 ;
+24 DO ^%ZISC
+25 ;
+26 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+27 KILL ^TMP("IBOUT",$JOB)
+28 ;
ENQ QUIT
+1 ;
PRINT(RTN,BDATE,EDATE,MAX) ; -- print the current data
+1 NEW REC,CNT,LCNT,RX,IBQUIT,FIRST,XX,NAME,LINE,ZZ,ZZ1,ZZ2,PGC,RNB
+2 SET LCNT=0
SET PGC=0
SET IBQUIT=0
+3 DO CLEAR^VALM1
+4 USE IO
+5 DO HEADER
+6 SET NAME=""
FOR
SET NAME=$ORDER(^TMP($JOB,"IBOHLS",NAME))
if NAME=""
QUIT
Begin DoDot:1
+7 SET FIRST=1
+8 SET CNT=0
FOR
SET CNT=$ORDER(^TMP($JOB,"IBOHLS",NAME,CNT))
if CNT=""
QUIT
Begin DoDot:2
+9 if $Y>MAX
DO HEADER
if IBQUIT
QUIT
+10 ;line#
SET LINE=$$SETL("","","",1,2)
+11 ;PATNAME^PATID^TYPE^FROM/FILL DATE^TO/RLS DATE^#DAYS ON HOLD^CHARGE
+12 SET REC=^TMP($JOB,"IBOHLS",NAME,CNT)
+13 SET LINE=$$SETL(LINE,$PIECE(REC,U),"",4,22)
+14 SET LINE=$$SETL(LINE,$PIECE(REC,U,2),"",26,6)
+15 SET LINE=$$SETL(LINE,$PIECE(REC,U,3),"",35,6)
+16 SET LINE=$$SETL(LINE,$$FMTE^XLFDT($PIECE(REC,U,4),"2DZ"),"",44,8)
+17 SET LINE=$$SETL(LINE,$$FMTE^XLFDT($PIECE(REC,U,5),"2DZ"),"",54,8)
+18 SET LINE=$$SETL(LINE,$PIECE(REC,U,6),"",63,5)
+19 SET LINE=$$SETL(LINE,$JUSTIFY($PIECE(REC,U,7),8,2),"",71,8)
+20 SET LCNT=LCNT+1
+21 SET ^TMP("IBOUT",$JOB,LCNT)=LINE
+22 IF $DATA(^TMP($JOB,"IBOHLS",NAME,CNT,1))
SET RX=^(1)
SET RX="Rx#:"_RX
Begin DoDot:3
+23 ;RX VALUE
+24 SET LINE=$$SETL("",RX,"",37,20)
+25 SET LCNT=LCNT+1
+26 SET ^TMP("IBOUT",$JOB,LCNT)=LINE
End DoDot:3
+27 IF $DATA(^TMP($JOB,"IBOHLS",NAME,CNT,2))
Begin DoDot:3
+28 ;BILL#AR STATUS^DATE BILLED^CHARGE
+29 SET BCNT=0
FOR
SET BCNT=$ORDER(^TMP($JOB,"IBOHLS",NAME,CNT,2,BCNT))
if BCNT=""
QUIT
Begin DoDot:4
+30 SET REC=^TMP($JOB,"IBOHLS",NAME,CNT,2,BCNT)
+31 SET LINE=$$SETL("","Bill: ","",6,18)
+32 SET LINE=$$SETL(LINE,$PIECE(REC,U),"",15,10)
+33 SET LINE=$$SETL(LINE,$PIECE(REC,U,2),"",26,10)
+34 SET LINE=$$SETL(LINE,$$FMTE^XLFDT($PIECE(REC,U,3),"2DZ"),"",39,8)
+35 SET LINE=$$SETL(LINE,$JUSTIFY($PIECE(REC,U,4),8,2),"",48,11)
+36 SET LCNT=LCNT+1
+37 SET ^TMP("IBOUT",$JOB,LCNT)=LINE
+38 SET RNB=$PIECE(REC,U,7)
+39 IF RNB'=""
Begin DoDot:5
+40 SET LINE=$$SETL("","RNB: ","",6,6)
+41 SET LINE=$$SETL(LINE,RNB,"",14,60)
End DoDot:5
End DoDot:4
End DoDot:3
+42 ; IF DISPLAYING INSURANCE INFORMATION
IF $DATA(^TMP($JOB,"IBOHLS",NAME,CNT,3))
IF FIRST
Begin DoDot:3
+43 NEW ZZ,ZZ1,ZZ2
+44 ;ins co^sub id^plan id^effective dt^expiration
+45 SET FIRST=0
+46 SET LINE=$$SETL("","Insurance","",8,9)
+47 SET LINE=$$SETL(LINE,"Subscriber","",28,10)
+48 SET LINE=$$SETL(LINE,"Group","",44,5)
+49 SET LINE=$$SETL(LINE,"Eff Dt","",54,6)
+50 SET LINE=$$SETL(LINE,"Exp Dt","",66,6)
+51 SET LCNT=LCNT+1
+52 SET ^TMP("IBOUT",$JOB,LCNT)=LINE
+53 SET LCNT=LCNT+1
+54 SET $PIECE(ZZ2,"-",68)=""
+55 SET LINE=$$SETL("",ZZ2,"",8,68)
+56 SET ^TMP("IBOUT",$JOB,LCNT)=LINE
+57 SET ZZ=0
FOR
SET ZZ=$ORDER(^TMP($JOB,"IBOHLS INS",NAME,ZZ))
if ZZ=""
QUIT
Begin DoDot:4
+58 ;plan coverage^effective date^covered?^limit
+59 SET ZZ1=^TMP($JOB,"IBOHLS INS",NAME,ZZ)
+60 SET LINE=$$SETL("",$PIECE(ZZ1,U),"",8,15)
+61 SET LINE=$$SETL(LINE,$PIECE(ZZ1,U,2),"",28,10)
+62 SET LINE=$$SETL(LINE,$PIECE(ZZ1,U,3),"",44,6)
+63 SET LINE=$$SETL(LINE,$$FMTE^XLFDT($PIECE(ZZ1,U,4),"2DZ"),"",54,8)
+64 SET LINE=$$SETL(LINE,$$FMTE^XLFDT($PIECE(ZZ1,U,5),"2DZ"),"",66,8)
+65 SET LCNT=LCNT+1
+66 SET ^TMP("IBOUT",$JOB,LCNT)=LINE
+67 SET LINE=$$SETL("","Plan Coverage Effective Date Covered? Limit Comments","",10,60)
+68 SET LCNT=LCNT+1
+69 SET ^TMP("IBOUT",$JOB,LCNT)=LINE
+70 SET ZZ2=0
FOR
SET ZZ2=$ORDER(^TMP($JOB,"IBOHLS INS",NAME,ZZ,ZZ2))
if ZZ2=""
QUIT
Begin DoDot:5
+71 SET ZZ1=^TMP($JOB,"IBOHLS INS",NAME,ZZ,ZZ2)
+72 SET LINE=$$SETL("",$PIECE(ZZ1,U),"",10,15)
+73 SET LINE=$$SETL(LINE,$$FMTE^XLFDT($PIECE(ZZ2,U,2),"2DZ"),"",28,8)
+74 SET LINE=$$SETL(LINE,$PIECE(ZZ1,U,3),"",46,10)
+75 SET LINE=$$SETL(LINE,$PIECE(ZZ1,U,4),"",59,20)
+76 SET LCNT=LCNT+1
+77 SET ^TMP("IBOUT",$JOB,LCNT)=LINE
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+78 ;
+79 SET XX=0
+80 FOR
SET XX=$ORDER(^TMP("IBOUT",$JOB,XX))
if XX=""
QUIT
if $Y>MAX
DO HEADER
if IBQUIT
QUIT
WRITE !,^TMP("IBOUT",$JOB,XX)
+81 WRITE !!,?5,"END OF REPORT"
+82 QUIT
+83 ;
+1 NEW DIR,X,Y,DTOUT,DUOUT,OFFSET,HDR,DASHES,DASHES2,LIN,IBPXT
+2 SET IBPXT=0
+3 ;
+4 IF CRT
IF PGC>0
IF '$DATA(ZTQUEUED)
Begin DoDot:1
+5 IF MAX<51
FOR LIN=1:1:(MAX-$Y)
WRITE !
+6 SET DIR(0)="E"
DO ^DIR
KILL DIR
+7 IF X="^"
SET IBQUIT=1
+8 IF $DATA(DTOUT)!$DATA(DUOUT)!(IBQUIT)
SET IBPXT=1
QUIT
End DoDot:1
IF IBPXT
GOTO HEADERX
+9 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD()
SET (ZTSTOP,IBPXT)=1
GOTO HEADERX
+10 SET PGC=PGC+1
+11 WRITE @IOF,!,?1,"VistA Held Charges Report"
+12 SET HDR=$$FMTE^XLFDT($$NOW^XLFDT,1)_" Page: "_PGC
+13 SET OFFSET=78-$LENGTH(HDR)
+14 WRITE ?OFFSET,HDR
+15 IF BDATE=0
SET BDATE="Beginning"
+16 IF BDATE>0
SET BDATE=$$FMTE^XLFDT(BDATE,"5Z")
+17 SET HDR=BDATE_" - "_$$FMTE^XLFDT(EDATE,"5Z")
+18 SET OFFSET=80-$LENGTH(HDR)\2
+19 WRITE !,?OFFSET,HDR
+20 WRITE !,?4,"Patient Name",?26,"ID",?35,"Type",?44,"Fr/Fl Dt",?54,"To/Rls Dt",?64,"Days",?73,"Amount"
+21 WRITE !,?2,"-----------------------------------------------------------------------------"
+1 QUIT
+2 ;
EXPORT(RTN,FILTERS) ; -- print excel spreadsheet.
+1 NEW REC,CNT,RX,IBQUIT,BDATE,EDATE,NAME
+2 SET LCNT=0
SET PGC=0
SET IBQUIT=0
+3 SET BDATE=$PIECE(FILTERS(0),U,1)
SET EDATE=$PIECE(FILTERS(0),U,2)
+4 DO ^%ZISC
+5 DO DEVICE("EF")
+6 ;
+7 DO BLD^IBOHLS
+8 DO PAUSE
+9 SET VALMBCK="R"
+10 QUIT
+11 ;
EXCEL(RTN,BDATE,EDATE,MAX) ; print the data in excel format
+1 USE IO
+2 NEW LINE,LCNT,PCE,REC,OUT,NAME,XX,BCNT,CNT,NXT,ZZ,ZZ1,ZZ2,OUT
+3 DO EXHDR
+4 SET LCNT=0
+5 SET NAME=""
FOR
SET NAME=$ORDER(^TMP($JOB,"IBOHLS",NAME))
if NAME=""
QUIT
DO COUNT
+6 ;
+7 SET XX=0
+8 FOR
SET XX=$ORDER(^TMP("IBOUT",$JOB,XX))
if XX=""
QUIT
WRITE !,^TMP("IBOUT",$JOB,XX)
+9 ;
+10 WRITE !,"END OF REPORT"
+11 DO PAUSE
+12 QUIT
+13 ;
COUNT ; format output
+1 NEW LINE,REC,REC1
+2 SET FIRST=1
SET CNT=0
SET LINE=""
+3 FOR
SET CNT=$ORDER(^TMP($JOB,"IBOHLS",NAME,CNT))
if CNT=""
QUIT
Begin DoDot:1
+4 SET LCNT=LCNT+1
+5 SET REC=^TMP($JOB,"IBOHLS",NAME,CNT)
+6 ;PATNAME^PATID^TYPE^Fr/Fl D^To/Rls^#Days On Hold^CHARGE $ Fr/Fl Dt and To/Rls
+7 SET $PIECE(REC,U,4)=$$FMTE^XLFDT($PIECE(REC,U,4),"2DZ")
+8 SET $PIECE(REC,U,5)=$$FMTE^XLFDT($PIECE(REC,U,5),"2DZ")
+9 SET ^TMP("IBOUT",$JOB,LCNT)=REC
+10 ;RX VALUE
+11 IF $DATA(^TMP($JOB,"IBOHLS",NAME,CNT,1))
SET $PIECE(^TMP("IBOUT",$JOB,LCNT),U,8)=^TMP($JOB,"IBOHLS",NAME,CNT,1)
+12 IF $DATA(^TMP($JOB,"IBOHLS",NAME,CNT,2))
Begin DoDot:2
+13 SET SVRC=^TMP("IBOUT",$JOB,LCNT)
SET REC=""
SET XX=0
+14 SET BCNT=0
FOR
SET BCNT=$ORDER(^TMP($JOB,"IBOHLS",NAME,CNT,2,BCNT))
if BCNT=""
QUIT
Begin DoDot:3
+15 ;BILL#^AR STATUS^DATE BILLED^CHARGE
+16 SET LINE=SVRC
+17 SET REC=$PIECE(^TMP($JOB,"IBOHLS",NAME,CNT,2,BCNT),U,1,6)
+18 SET $PIECE(REC,U,3)=$$FMTE^XLFDT($PIECE(REC,U,3),"2DZ")
+19 SET REC1=$PIECE(REC,U,1,3)_U_$PIECE(REC,U,6)
+20 SET XX=XX+1
+21 IF XX=1
SET $PIECE(^TMP("IBOUT",$JOB,LCNT),U,9)=REC1
+22 IF XX>1
SET LCNT=LCNT+1
SET $PIECE(LINE,U,9)=REC1
SET ^TMP("IBOUT",$JOB,LCNT)=LINE
SET LINE=""
End DoDot:3
End DoDot:2
End DoDot:1
+23 ;DON'T USE INSURANCE INFO. IT WILL BE TOO LONG.
QUIT
+24 ;
EXHDR ; -- excel header
+1 SET HDR="Patient Name"_U_"ID"_U_"Type"_U_"Fr/Fl Dt"_U_"To/Rls Dt"_U_"Days"_U_"Amount"_U_"RX"_U_"BILL"_U_"AR STATUS"_U_"DATE BILLED"_U_"CHARGE"
+2 WRITE !,HDR
+3 QUIT
+4 ;
PAUSE ;pause at end of screen if being displayed on a terminal
+1 if $EXTRACT(IOST,1,2)'["C-"
QUIT
NEW DIR,DUOUT,DTOUT,DIRUT
WRITE !
+2 SET DIR(0)="E"
DO ^DIR
KILL DIR
+3 IF $DATA(DUOUT)!($DATA(DIRUT))
SET IBQUIT=1
+4 QUIT
+5 ;
PATINS ; view patient insurance
+1 DO FULL^VALM1
+2 NEW I,J,IBXX,VALMY,ECNT,DFN,GOPAT
+3 DO EN^VALM2($GET(XQORNOD(0)))
+4 IF $DATA(VALMY)
SET IBXX=0
FOR
SET IBXX=$ORDER(VALMY(IBXX))
if 'IBXX
QUIT
Begin DoDot:1
+5 SET REC=$GET(^TMP($JOB,"IBOHLSX",IBXX))
+6 SET DFN=$PIECE(REC,U,1)
+7 DO EN^VALM("IBCNS VIEW PAT INS")
End DoDot:1
+8 DO BLD^IBOHLS
+9 SET VALMBCK="R"
+10 QUIT
+11 ;
CLMTRK ; look at claims tracking
+1 DO FULL^VALM1
+2 NEW I,J,IBXX,VALMY,ECNT,NAME,GOTPAT,RC,IBFR,IBTO
+3 DO EN^VALM2($GET(XQORNOD(0)))
+4 KILL ^TMP($JOB,"IBOHLS CLMTRK")
+5 IF $DATA(VALMY)
SET IBXX=0
FOR
SET IBXX=$ORDER(VALMY(IBXX))
if 'IBXX
QUIT
Begin DoDot:1
+6 SET RC=$GET(^TMP($JOB,"IBOHLSX",IBXX))
+7 SET DFN=$PIECE(RC,U,1)
SET NAME=$PIECE(RC,U,2)
SET ECNT=$PIECE(RC,U,3)
SET GOTPAT=1
+8 SET RC=^TMP($JOB,"IBOHLSF")
+9 SET IBFR=$PIECE(RC,U,1)
SET IBTO=$PIECE(RC,U,2)
+10 SET ^TMP($JOB,"IBCLMTRK")=DFN_U_IBFR_U_IBTO
+11 DO EN^VALM("IBT CLAIMS TRACKING EDITOR")
End DoDot:1
+12 KILL ^TMP($JOB,"IBOHLS CLMTRK")
+13 DO BLD^IBOHLS
+14 SET VALMBCK="R"
+15 QUIT
+16 ;
PATCLM ; look at claims INFO
+1 DO FULL^VALM1
+2 NEW IBXX,VALMY,ECNT,PNAME,RC,XX,IBIFN
+3 DO EN^VALM2($GET(XQORNOD(0)))
+4 IF $DATA(VALMY)
SET IBXX=0
FOR
SET IBXX=$ORDER(VALMY(IBXX))
if 'IBXX
QUIT
Begin DoDot:1
+5 SET RC=$GET(^TMP($JOB,"IBOHLSX",IBXX))
+6 SET DFN=$PIECE(RC,U,1)
SET NAME=$PIECE(RC,U,2)
SET ECNT=$PIECE(RC,U,3)
+7 DO EN^VALM("IBJT ACTIVE LIST")
End DoDot:1
+8 DO BLD^IBOHLS
+9 SET VALMBCK="R"
+10 QUIT
+11 ;
PATACP ; look at ACCOUNT PROFILE
+1 DO FULL^VALM1
+2 NEW IBXX,VALMY,ECNT,NAME,RC,DFN,CPY,PRCATY
+3 DO EN^VALM2($GET(XQORNOD(0)))
+4 DO CLEAR^VALM1
+5 IF $DATA(VALMY)
SET IBXX=0
FOR
SET IBXX=$ORDER(VALMY(IBXX))
if 'IBXX
QUIT
Begin DoDot:1
+6 SET RC=$GET(^TMP($JOB,"IBOHLSX",IBXX))
+7 SET DFN=$PIECE(RC,U,1)
SET NAME=$PIECE(RC,U,2)
SET ECNT=$PIECE(RC,U,3)
+8 NEW DIC,X,Y,DEBT,PRCADB,DA,PRCA,COUNT,OUT,SEL,BILL,BAT,TRAN,DR,DXS,DTOUT,DIROUT,DIRUT,DUOUT
+9 NEW DPTNOFZY,DPTNOFZK
SET (DPTNOFZY,DPTNOFZK)=1
+10 SET COUNT=0
SET CPY=1
+11 SET PRCATY="ALL"
SET X=NAME
+12 SET X=$$UPPER^VALM1(X)
+13 SET Y=$SELECT($ORDER(^PRCA(430,"B",X,0)):$ORDER(^(0)),$ORDER(^PRCA(430,"D",X,0)):$ORDER(^(0)),1:-1)
+14 IF Y>0
SET DEBT=$PIECE($GET(^PRCA(430,Y,0)),"^",9)
IF DEBT
SET PRCADB=$PIECE($GET(^RCD(340,DEBT,0)),"^")
SET ^DISV(DUZ,"^PRCA(430,")=Y
SET $PIECE(DEBT,"^",2)=$$NAM^RCFN01(DEBT)
DO COMP^PRCAAPR
DO EN1^PRCAATR(Y)
QUIT
+15 SET DIC="^RCD(340,"
SET DIC(0)="E"
DO ^DIC
+16 IF Y<0
WRITE !,"No entries found for "_NAME
QUIT
+17 SET ^DISV(DUZ,"^RCD(340,")=+Y
+18 SET PRCADB=$PIECE(Y,"^",2)
SET DEBT=+Y_"^"_$PIECE(@("^"_$PIECE(PRCADB,";",2)_+PRCADB_",0)"),"^")
+19 DO COMP^PRCAAPR
DO HDR^PRCAAPR1
DO HDR2^PRCAAPR1
DO DIS^PRCAAPR1
+20 DO PAUSE^VALM1
End DoDot:1
+21 KILL ^TMP("PRCAAPR",$JOB)
+22 DO BLD^IBOHLS
+23 SET VALMBCK="R"
+24 QUIT
+25 ;
SETL(LINE,DATA,LABEL,COL,LNG) ; Creates a line of data to be set into the body
+1 ; of the worklist
+2 ; Input: LINE - Current line being created
+3 ; DATA - Information to be added to the end of the current line
+4 ; LABEL - Label to describe the information being added
+5 ; COL - Column position in line to add information add
+6 ; LNG - Maximum length of data information to include on the line
+7 ; Returns: Line updated with added information
+8 SET LINE=LINE_$JUSTIFY("",(COL-$LENGTH(LABEL)-$LENGTH(LINE)))_LABEL_$EXTRACT(DATA,1,LNG)
+9 QUIT LINE
+10 ;
QUE ; QUEUED REPORT ENTRY
+1 ;Required variable input: FILTERS(0),FILTERS(1),FILTERS(2),BDATE,EDATE,INSTS,PATS,IINS,CRT,TYPE
+2 ;
+3 DO FULL^VALM1
+4 DO CLEAR^VALM1
+5 SET BDATE=$PIECE(FILTERS(0),U,1)
SET EDATE=$PIECE(FILTERS(0),U,2)
+6 SET INSTS=$PIECE(FILTERS(0),U,3)
SET PATS=$PIECE(FILTERS(0),U,4)
+7 SET IINS=FILTERS(3)
+8 DO SORT^IBOHLS1
+9 ;
+10 IF TYPE="PR"
USE IO
DO PRINT("IBOHLS",BDATE,EDATE,MAXCNT)
+11 IF TYPE="EF"
USE IO
DO EXCEL("IBOHLS",BDATE,EDATE,MAXCNT)
+12 QUIT
