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

IBOLK.m

Go to the documentation of this file.
  1. IBOLK ;ALB/AAS - INTEGRATED BILLING - DISPLAY BY BILL NUMBER ;6-MAR-91
  1. ;;2.0;INTEGRATED BILLING ;**199,420,433,618**;21-MAR-94;Build 61
  1. ;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. % ;
  1. ;***
  1. ;I $D(XRT0) S:'$D(XRTN) XRTN="IBOLK" D T1^%ZOSV ;stop rt clock
  1. ;S XRTL=$ZU(0),XRTN="IBOLK-1" D T0^%ZOSV ;start rt clock
  1. N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy lookups
  1. S DIC("A")="Select CHARGE ID or PATIENT NAME: ",DIC="^PRCA(430,",DIC(0)="AEQM" D ^DIC K DIC G END1:+Y<1 S IBIL=$P(Y,"^",2)
  1. ; user needs to be able to look-up any iteration ie. K600111 or K600111-01
  1. ;S IBIFN=$O(^DGCR(399,"B",$P(IBIL,"-",2),0))
  1. S IBIFN=$O(^DGCR(399,"B",$P(IBIL,"-",2,3),0))
  1. I '$D(^IB("ABIL",IBIL)),'IBIFN W !!,"Billing has no Record of this Charge ID.",! G %
  1. ;
  1. BRIEF R !,"(B)rief or (F)ull Inquiry: B// ",X:DTIME G:X="^"!('$T) END1 S:X="" X="B" S X=$E(X)
  1. I "BFbf"'[X D G BRIEF
  1. . W !!?5,"Enter: '<CR>' - To select the Brief Inquiry."
  1. . W !?12,"'F' - To select the Full Inquiry. This option will"
  1. . W !?23,"include the Address Inquiry, and more detailed"
  1. . W !?23,"information for Pharmacy Co-Pay bills."
  1. . W !?12,"'^' - To quit this option.",!
  1. W $S("Bb"[X:" BRIEF",1:" FULL") S IBFULL="Ff"[X
  1. I IBIFN S IBAC=8,IBQUIT=0
  1. ;
  1. DEV W ! S %ZIS="QM",%ZIS("A")="Output Device: " D ^%ZIS G:POP END
  1. I $D(IO("Q")) D D ^%ZTLOAD K IO("Q") D HOME^%ZIS W ! G %
  1. . S ZTDESC="IB Print Actions by Bill Number"
  1. . S ZTRTN=$S(IBIFN:"VIEW^IBCNQ",1:"EN^IBOLK")
  1. . S ZTSAVE("IBFULL")="",ZTSAVE("IBIL")="",ZTSAVE("IBIFN")=""
  1. . I IBIFN F I="IBAC","IBQUIT" S ZTSAVE(I)=""
  1. ;
  1. U IO
  1. ;***
  1. ;I $D(XRT0) S:'$D(XRTN) XRTN="IBOLK" D T1^%ZOSV ;stop rt clock
  1. I 'IBIFN D EN G %
  1. D VIEW^IBCNQ,Q^IBCNQ,END1 G %
  1. ;
  1. EN ; -Entry to display IB Action data for an AR Bill number
  1. ; -Input IBIL = external form of bill number, ie 500-K10001
  1. ; IBFULL = 1 for full profile logic, 0 for brief description
  1. ;***
  1. ;S XRTL=$ZU(0),XRTN="IBOLK-2" D T0^%ZOSV ;start rt clock
  1. S IBN=$O(^IB("ABIL",IBIL,"")) G:'$D(^IB(IBN,0)) ENQ
  1. S IBTOTL=0,IBQUIT="",IBPAG=0 D NOW^%DTC S IBHDT=$$DAT2^IBOUTL($E(%,1,12)) D HDR
  1. ;
  1. S IBN="" F IBI=0:0 S IBN=$O(^IB("ABIL",IBIL,IBN)) Q:'IBN I $D(^IB(IBN,0)) D LINE Q:IBQUIT
  1. I 'IBQUIT D TOTAL,PAUSE,^IBOLK1:IBFULL&('IBQUIT)
  1. ENQ D END Q
  1. ;
  1. LINE ; -find data for one line, write line, accumulate totals
  1. I '$D(IBTRAN),$Y>(IOSL-5) D PAUSE Q:IBQUIT D HDR1
  1. S IBND=^IB(IBN,0),IBND1=$G(^(1))
  1. I IBFULL,$D(^IBE(350.1,+$P(IBND,"^",3),30)),+$P(IBND,"^",4)=52 W ! S X1=$P($P($P(IBND,"^",4),";",1),":",2),X2=$P($P($P(IBND,"^",4),";",2),":",2),X=X1_"^"_$S(X2:X2,1:0) X ^(30)
  1. S IBTYP=$G(^IBE(350.1,+$P(IBND,"^",3),0)),IBSEQNO=$P(IBTYP,"^",5)
  1. W ! S Y=$P($P(IBND1,"^",2),".",1) D DT^DIQ
  1. ;IB*2.0*618 Corrected display for new Action Types
  1. S IBTYP=$S($E(IBTYP,1,2)="DG":$P(IBTYP," ",2,99),$E(IBTYP,1,3)="PSO":$P(IBTYP," ",2,99),1:IBTYP)
  1. W ?15,$E($P(IBTYP,"^"),1,20)
  1. ; display brief description if not a CC action type
  1. I ($P(IBTYP,U)'["CC"),($P(IBTYP,U)'["CHOICE") W ?37,$E($P(IBND,"^",8),1,20)
  1. ;end IB*2.0*618
  1. W ?60,$J($P(IBND,"^",6),5)
  1. S IBCHRG=$P(IBND,"^",7) I IBSEQNO=2 S IBCHRG=(-IBCHRG) ;cancel types are decrease adjustments
  1. S X=IBCHRG,X2="2$",X3=10 D COMMA^%DTC W ?69,X
  1. S IBTOTL=IBTOTL+IBCHRG
  1. I $P(IBND,"^",10),IBSEQNO=2 W !,?5,"Charge Removal Reason: ",$S($D(^IBE(350.3,$P(IBND,"^",10),0)):$P(^(0),"^"),1:"UNKNOWN")
  1. Q
  1. ;
  1. HDR S IBND=^IB(IBN,0),DFN=+$P(IBND,"^",2),IBNAME=$$PT^IBEFUNC(DFN)
  1. HDR1 S IBPAG=IBPAG+1 I $E(IOST,1,2)["C-"!(IBPAG>1) W @IOF,*13
  1. ;W $E($P(IBNAME,"^"),1,20)," ",$P(IBNAME,"^",2),?38,IBIL,?51,IBHDT,?72,"PAGE: ",IBPAG
  1. W $E($P(IBNAME,"^"),1,20)," ",$P(IBNAME,"^",2),?36,IBIL,?51,IBHDT,?72,"PAGE: ",IBPAG
  1. D DISP^IBARXEU(DFN,DT,2) W !
  1. W:'IBFULL !,"DATE",?15,"CHARGE TYPE",?37,"BRIEF DESCRIPTION",?62,"UNITS",?73,"CHARGE"
  1. S IBLINE="",$P(IBLINE,"=",IOM)="" W !,IBLINE K IBLINE
  1. Q
  1. ;
  1. TOTAL W !?67,"------------" S X=IBTOTL,X2="2$",X3=12 D COMMA^%DTC
  1. W !,?67,X
  1. Q
  1. ;
  1. PAUSE Q:$E(IOST,1,2)'["C-"
  1. F IBJ=$Y:1:(IOSL-4) W !
  1. S DIR(0)="E" D ^DIR K DIR I $D(DIRUT)!($D(DUOUT)) S IBQUIT=1 K DIRUT,DTOUT,DUOUT
  1. Q
  1. ;
  1. END1 K IBFULL
  1. END W !
  1. ;***
  1. ;I $D(XRT0) S:'$D(XRTN) XRTN="IBOLK" D T1^%ZOSV ;stop rt clock
  1. I $D(ZTQUEUED) S ZTREQ="@" Q
  1. K X,X2,X3,Y,DFN,IBIFN,IBAC,I,IB,IBIL,IBI,IBJ,IBNAME,IBLINE,IBN,IBND,IBND1,IBCHRG,IBSEQNO,IBTYP,IBTOTL,ZTSK,IBHDT,IBPAG,IBQUIT,DN,D0,DUOUT,DTOUT,VA,VADM,VAERR
  1. D ^%ZISC
  1. Q
  1. ;
  1. ENF ; -entry point for AR to print full profile for IB actions for
  1. ; an ar transaction number.
  1. ; -input x = ar transaction number ($p(^ib(ibn,0),u,12)
  1. ;
  1. S IBFULL=1
  1. ;
  1. ENB ; -entry point for AR to print brief profile for IB actions for
  1. ; an ar transaction number.
  1. ; -input x = ar transaction number
  1. ;
  1. S IBTOTL=0,IBPAG=0,IBQUIT="" S:'$D(IBFULL) IBFULL=0
  1. S IBTRAN=X
  1. S IBN="" F S IBN=$O(^IB("AT",IBTRAN,IBN)) Q:IBN="" D LINE
  1. K D0,DN,X,X2,X3,Y,IBFULL,IBTOTL,IBPAG,IBQUIT,IBTRAN,IBN,IBND,IBND1,IBSEQNO,IBTYP,IBCHRG
  1. Q