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

IBOHLS2.m

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