- 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 Jan 18, 2025@03:26:51 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