IBCA3 ;ALB/AAS - MCCR SINGLE LINE DISPLAY OF BILL ;12/22/89
;;2.0;INTEGRATED BILLING;**52,80,106,51**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
;MAP TO DGCRA3
;
EN1 ;entry for one bill, must pass IBIFN
K DGSELNO D HDR,ONE
G END
;
EN2 ;Find all bills for a patient must pass dfn
S IBQUIT=0 D UTIL S:'$D(IBPAUS) IBPAUS=5
I 'IBCNT W !,"No Bills On File for this Patient!" G EN2Q
K DGSELNO D HDR S (IBDT,IBIFN)="",IBCNT=0
F K=0:0 S IBDT=$O(^UTILITY($J,IBDT)) Q:IBDT=""!(IBQUIT) F J=0:0 S IBIFN=$O(^UTILITY($J,IBDT,IBIFN)) Q:IBIFN=""!(IBQUIT) S IBCNT=IBCNT+1 D ONE,PAUSE:'(IBCNT#IBPAUS)
EN2Q D END Q
;
EN3 ;Find all bills for a patient on one episode date. must pass dfn, episode date in x
S IBQUIT=0 D UTIL,UTIL1
I 'IBCNT W !,"No Other Bills for this Episode Date on File!" G EN3Q
K DGSELNO S IBIFN="",IBCNT=0,IBDT=-(X+.99),IBDT1=X
F K=0:0 S IBDT=$O(^UTILITY($J,IBDT)) Q:IBDT=""!(IBQUIT)!(IBDT>-IBDT1) F J=0:0 S IBIFN=$O(^UTILITY($J,IBDT,IBIFN)) Q:IBIFN=""!(IBQUIT) S IBCNT=IBCNT+1 D HDR:IBCNT=1,ONE,PAUSE:'(IBCNT#5)
F K=0:0 S K=$O(^UTILITY($J,"IB",K)) Q:'K!(IBQUIT) S IBCNT=IBCNT+1 D HDR1:IBCNT=1,ONE1,PAUSE:'(IBCNT#5)
I 'IBCNT W !,"No Other Bills for this Episode Date on File!" G EN3Q
EN3Q D END Q
EN4 ;Find all bills beginning a CEOC and allow selection by number, pass dfn
K ^UTILITY($J) S (DGSELNO,IBQUIT)=0 D UTIL
I 'IBCNT W !,"No Other Bills for this Episode Date on File!" G EN4Q
S (IBDT,IBIFN)="",IBCNT=0,IBPAUS=5
F K=0:0 S IBDT=$O(^UTILITY($J,IBDT)) Q:'IBDT!(IBQUIT) D 41
D:'IBQUIT PAUSE:'$D(IBIDS(.17))
EN4Q K DIC,DGSELNO D END Q
;
41 F J=0:0 S IBIFN=$O(^UTILITY($J,IBDT,IBIFN)) Q:'IBIFN!(IBQUIT) D SCRN ;S IBCNT=IBCNT+1 D ONE,PAUSE:'(IBCNT#IBPAUS)
Q
SCRN S A=$P(^DGCR(399,IBIFN,0),"^",17)
I A=IBIFN S DGSELNO=DGSELNO+1,^UTILITY($J,"IBSEL",DGSELNO)=IBIFN,^UTILITY($J,"IBSEL",$P(^DGCR(399,A,0),"^"))=IBIFN D HDR:DGSELNO=1,ONE,PAUSE:'(DGSELNO#IBPAUS)
Q
;
ONE D GVAR^IBCBB W !
S DGTAB=2 I $D(DGSELNO) W DGSELNO S DGTAB=4 ;write selection numbers here
W ?DGTAB,IBBNO,?13,$S($P(IBND0,U,27)=1:"I",$P(IBND0,U,27)=2:"P",1:"")
W ?15,$S(IBCL=2:"HE ",IBCL=4:"HE ",1:""),$$BCHGTYPE^IBCU(IBIFN),?29
W $S(IBWHO="p":"Pat",IBWHO="i":"Ins",1:"Oth"),$S($P(IBND0,U,21)="S":" s",$P(IBND0,U,21)="T":" t",1:""),?36
F I=IBEVDT,IBFDT,IBTDT W $E(I,4,5)_"/"_$E(I,6,7)_"/"_$E(I,2,3)," "
W ?66,$S(IBST=1:"Enterd",IBST=2:"ReqMRA",IBST=3:"Auth. ",IBST=4:"Pr/Txd",1:"Cancel")," "
W ?74,$S(IBTF=1:"Ad-Ds",IBTF=2:"Int FC",IBTF=3:"Int CC",IBTF=4:"Int LC",IBTF=5:"Late",IBTF=6:"Adjust",IBTF=7:"Replac",IBTF=0:"ZERO",1:"")
Q
;
ONE1 ; Display IB Actions. Input: K, X
N C,D,I,Y S D=$G(^IB(K,0))
W !,?2,$P($P(D,"^",11),"-",2),?13,$S($P($G(^IBE(350.1,+$P(D,"^",3),0)),"^")["OPT":"Outpt.",1:"Inpat."),?28,"Patnt",?36
F I=X,$P(D,"^",14),$P(D,"^",15) W $$DAT1^IBOUTL(I)," "
S C=$P(^DD(350,.05,0),"^",2),Y=$P(D,"^",5) D Y^DIQ W ?66,$E(Y,1,4),?72,$$ACTNM($P(D,"^",3),1)
Q
;
HDR S DGTAB=$S($D(DGSELNO):4,1:2) W !,?DGTAB,"Bill #",?13,"Classf ($typ)",?29,"Payer",?36,"Event DT From DT To Date",?66,"Status",?74,"Timefm"
W !,?DGTAB,"------",?13,"-------------",?29,"-----",?36,"-------- -------- --------",?66,"------",?74,"------"
Q
;
HDR1 ; Write header to dislay IB Actions.
W !,?2,"Bill #",?13,"Classf",?28,"Payer",?36,"Event DT From DT To Date",?66,"Stat",?72,"Act Typ"
W !,?2,"------",?13,"-------",?28,"-----",?36,"-------- -------- --------",?66,"----",?72,"------"
Q
;
PAUSE I '$D(DGSELNO),$E(IOST,1,2)["C-" R !!,"Enter ""^"" to quit display, return to continue",IBX1:DTIME S IBQUIT=$S(IBX1["^":1,'$T:1,1:0) Q
ASK I '$D(DGSELNO),DGSELNO<1 Q
W !!,"CHOOSE 1" W:DGSELNO>1 "-",DGSELNO W " or ENTER BILL NUMBER: " R IBX:DTIME I IBX="^"!('$T) S IBQUIT=1 Q
Q:IBX=""
I $D(^UTILITY($J,"IBSEL",IBX)) S Y=^(IBX) I $D(^DGCR(399,Y,0)) S Y(0)=^(0) W " ",$P(Y(0),"^") S IBIDS(.17)=$P(Y(0),"^",17),IBQUIT=1 Q
;
HELPSEL W !!,"Enter 1-",DGSELNO," to select that entry or enter the Bill Number" G ASK
Q
;
UTIL S IBIFN1="",IBCNT=0 K ^UTILITY($J)
F J=0:0 S IBIFN1=$O(^DGCR(399,"C",DFN,IBIFN1)) Q:IBIFN1="" S IBCNT=IBCNT+1,IBEVDT=$P(^DGCR(399,IBIFN1,0),"^",3),^UTILITY($J,-IBEVDT,IBIFN1)=""
Q
;
UTIL1 ; Get IB charges for a patient for a single event date. Input: DFN, X
N Y,Y1
S Y=0 F S Y=$O(^IB("AFDT",DFN,-X,Y)) Q:'Y S Y1=0 F S Y1=$O(^IB("AF",Y,Y1)) Q:'Y1 I $D(^IB(Y1,0)),$P(^(0),"^",8)'["ADMISSION" S IBCNT=IBCNT+1,^UTILITY($J,"IB",Y1)=""
Q
;
END D END^IBCBB1
K A,DGTAB,IBIFN1,IBPAUS,IBQUIT,IBX1,IBDT,IBDT1,IBCNT,^UTILITY($J)
Q
;
ACTNM(X,P) ; returns external form of action type (350.1), short or long
N X1,Y S P=$S(+$G(P):2,1:8),X=+$G(X)
S X1=$P($G(^IBE(350.1,+X,0)),"^",9) ;new action type
S Y=$P($G(^IBE(350.1,+X1,0)),"^",P) I Y="" S Y=$P($G(^IBE(350.1,+X,0)),"^",P) I Y="" S Y=$P($G(^IBE(350.1,+X,0)),"^")
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCA3 4895 printed Sep 15, 2024@21:32:36 Page 2
IBCA3 ;ALB/AAS - MCCR SINGLE LINE DISPLAY OF BILL ;12/22/89
+1 ;;2.0;INTEGRATED BILLING;**52,80,106,51**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ;MAP TO DGCRA3
+5 ;
EN1 ;entry for one bill, must pass IBIFN
+1 KILL DGSELNO
DO HDR
DO ONE
+2 GOTO END
+3 ;
EN2 ;Find all bills for a patient must pass dfn
+1 SET IBQUIT=0
DO UTIL
if '$DATA(IBPAUS)
SET IBPAUS=5
+2 IF 'IBCNT
WRITE !,"No Bills On File for this Patient!"
GOTO EN2Q
+3 KILL DGSELNO
DO HDR
SET (IBDT,IBIFN)=""
SET IBCNT=0
+4 FOR K=0:0
SET IBDT=$ORDER(^UTILITY($JOB,IBDT))
if IBDT=""!(IBQUIT)
QUIT
FOR J=0:0
SET IBIFN=$ORDER(^UTILITY($JOB,IBDT,IBIFN))
if IBIFN=""!(IBQUIT)
QUIT
SET IBCNT=IBCNT+1
DO ONE
if '(IBCNT#IBPAUS)
DO PAUSE
EN2Q DO END
QUIT
+1 ;
EN3 ;Find all bills for a patient on one episode date. must pass dfn, episode date in x
+1 SET IBQUIT=0
DO UTIL
DO UTIL1
+2 IF 'IBCNT
WRITE !,"No Other Bills for this Episode Date on File!"
GOTO EN3Q
+3 KILL DGSELNO
SET IBIFN=""
SET IBCNT=0
SET IBDT=-(X+.99)
SET IBDT1=X
+4 FOR K=0:0
SET IBDT=$ORDER(^UTILITY($JOB,IBDT))
if IBDT=""!(IBQUIT)!(IBDT>-IBDT1)
QUIT
FOR J=0:0
SET IBIFN=$ORDER(^UTILITY($JOB,IBDT,IBIFN))
if IBIFN=""!(IBQUIT)
QUIT
SET IBCNT=IBCNT+1
if IBCNT=1
DO HDR
DO ONE
if '(IBCNT#5)
DO PAUSE
+5 FOR K=0:0
SET K=$ORDER(^UTILITY($JOB,"IB",K))
if 'K!(IBQUIT)
QUIT
SET IBCNT=IBCNT+1
if IBCNT=1
DO HDR1
DO ONE1
if '(IBCNT#5)
DO PAUSE
+6 IF 'IBCNT
WRITE !,"No Other Bills for this Episode Date on File!"
GOTO EN3Q
EN3Q DO END
QUIT
EN4 ;Find all bills beginning a CEOC and allow selection by number, pass dfn
+1 KILL ^UTILITY($JOB)
SET (DGSELNO,IBQUIT)=0
DO UTIL
+2 IF 'IBCNT
WRITE !,"No Other Bills for this Episode Date on File!"
GOTO EN4Q
+3 SET (IBDT,IBIFN)=""
SET IBCNT=0
SET IBPAUS=5
+4 FOR K=0:0
SET IBDT=$ORDER(^UTILITY($JOB,IBDT))
if 'IBDT!(IBQUIT)
QUIT
DO 41
+5 if 'IBQUIT
if '$DATA(IBIDS(.17))
DO PAUSE
EN4Q KILL DIC,DGSELNO
DO END
QUIT
+1 ;
41 ;S IBCNT=IBCNT+1 D ONE,PAUSE:'(IBCNT#IBPAUS)
FOR J=0:0
SET IBIFN=$ORDER(^UTILITY($JOB,IBDT,IBIFN))
if 'IBIFN!(IBQUIT)
QUIT
DO SCRN
+1 QUIT
SCRN SET A=$PIECE(^DGCR(399,IBIFN,0),"^",17)
+1 IF A=IBIFN
SET DGSELNO=DGSELNO+1
SET ^UTILITY($JOB,"IBSEL",DGSELNO)=IBIFN
SET ^UTILITY($JOB,"IBSEL",$PIECE(^DGCR(399,A,0),"^"))=IBIFN
if DGSELNO=1
DO HDR
DO ONE
if '(DGSELNO#IBPAUS)
DO PAUSE
+2 QUIT
+3 ;
ONE DO GVAR^IBCBB
WRITE !
+1 ;write selection numbers here
SET DGTAB=2
IF $DATA(DGSELNO)
WRITE DGSELNO
SET DGTAB=4
+2 WRITE ?DGTAB,IBBNO,?13,$SELECT($PIECE(IBND0,U,27)=1:"I",$PIECE(IBND0,U,27)=2:"P",1:"")
+3 WRITE ?15,$SELECT(IBCL=2:"HE ",IBCL=4:"HE ",1:""),$$BCHGTYPE^IBCU(IBIFN),?29
+4 WRITE $SELECT(IBWHO="p":"Pat",IBWHO="i":"Ins",1:"Oth"),$SELECT($PIECE(IBND0,U,21)="S":" s",$PIECE(IBND0,U,21)="T":" t",1:""),?36
+5 FOR I=IBEVDT,IBFDT,IBTDT
WRITE $EXTRACT(I,4,5)_"/"_$EXTRACT(I,6,7)_"/"_$EXTRACT(I,2,3)," "
+6 WRITE ?66,$SELECT(IBST=1:"Enterd",IBST=2:"ReqMRA",IBST=3:"Auth. ",IBST=4:"Pr/Txd",1:"Cancel")," "
+7 WRITE ?74,$SELECT(IBTF=1:"Ad-Ds",IBTF=2:"Int FC",IBTF=3:"Int CC",IBTF=4:"Int LC",IBTF=5:"Late",IBTF=6:"Adjust",IBTF=7:"Replac",IBTF=0:"ZERO",1:"")
+8 QUIT
+9 ;
ONE1 ; Display IB Actions. Input: K, X
+1 NEW C,D,I,Y
SET D=$GET(^IB(K,0))
+2 WRITE !,?2,$PIECE($PIECE(D,"^",11),"-",2),?13,$SELECT($PIECE($GET(^IBE(350.1,+$PIECE(D,"^",3),0)),"^")["OPT":"Outpt.",1:"Inpat."),?28,"Patnt",?36
+3 FOR I=X,$PIECE(D,"^",14),$PIECE(D,"^",15)
WRITE $$DAT1^IBOUTL(I)," "
+4 SET C=$PIECE(^DD(350,.05,0),"^",2)
SET Y=$PIECE(D,"^",5)
DO Y^DIQ
WRITE ?66,$EXTRACT(Y,1,4),?72,$$ACTNM($PIECE(D,"^",3),1)
+5 QUIT
+6 ;
HDR SET DGTAB=$SELECT($DATA(DGSELNO):4,1:2)
WRITE !,?DGTAB,"Bill #",?13,"Classf ($typ)",?29,"Payer",?36,"Event DT From DT To Date",?66,"Status",?74,"Timefm"
+1 WRITE !,?DGTAB,"------",?13,"-------------",?29,"-----",?36,"-------- -------- --------",?66,"------",?74,"------"
+2 QUIT
+3 ;
HDR1 ; Write header to dislay IB Actions.
+1 WRITE !,?2,"Bill #",?13,"Classf",?28,"Payer",?36,"Event DT From DT To Date",?66,"Stat",?72,"Act Typ"
+2 WRITE !,?2,"------",?13,"-------",?28,"-----",?36,"-------- -------- --------",?66,"----",?72,"------"
+3 QUIT
+4 ;
PAUSE IF '$DATA(DGSELNO)
IF $EXTRACT(IOST,1,2)["C-"
READ !!,"Enter ""^"" to quit display, return to continue",IBX1:DTIME
SET IBQUIT=$SELECT(IBX1["^":1,'$TEST:1,1:0)
QUIT
ASK IF '$DATA(DGSELNO)
IF DGSELNO<1
QUIT
+1 WRITE !!,"CHOOSE 1"
if DGSELNO>1
WRITE "-",DGSELNO
WRITE " or ENTER BILL NUMBER: "
READ IBX:DTIME
IF IBX="^"!('$TEST)
SET IBQUIT=1
QUIT
+2 if IBX=""
QUIT
+3 IF $DATA(^UTILITY($JOB,"IBSEL",IBX))
SET Y=^(IBX)
IF $DATA(^DGCR(399,Y,0))
SET Y(0)=^(0)
WRITE " ",$PIECE(Y(0),"^")
SET IBIDS(.17)=$PIECE(Y(0),"^",17)
SET IBQUIT=1
QUIT
+4 ;
HELPSEL WRITE !!,"Enter 1-",DGSELNO," to select that entry or enter the Bill Number"
GOTO ASK
+1 QUIT
+2 ;
UTIL SET IBIFN1=""
SET IBCNT=0
KILL ^UTILITY($JOB)
+1 FOR J=0:0
SET IBIFN1=$ORDER(^DGCR(399,"C",DFN,IBIFN1))
if IBIFN1=""
QUIT
SET IBCNT=IBCNT+1
SET IBEVDT=$PIECE(^DGCR(399,IBIFN1,0),"^",3)
SET ^UTILITY($JOB,-IBEVDT,IBIFN1)=""
+2 QUIT
+3 ;
UTIL1 ; Get IB charges for a patient for a single event date. Input: DFN, X
+1 NEW Y,Y1
+2 SET Y=0
FOR
SET Y=$ORDER(^IB("AFDT",DFN,-X,Y))
if 'Y
QUIT
SET Y1=0
FOR
SET Y1=$ORDER(^IB("AF",Y,Y1))
if 'Y1
QUIT
IF $DATA(^IB(Y1,0))
IF $PIECE(^(0),"^",8)'["ADMISSION"
SET IBCNT=IBCNT+1
SET ^UTILITY($JOB,"IB",Y1)=""
+3 QUIT
+4 ;
END DO END^IBCBB1
+1 KILL A,DGTAB,IBIFN1,IBPAUS,IBQUIT,IBX1,IBDT,IBDT1,IBCNT,^UTILITY($JOB)
+2 QUIT
+3 ;
ACTNM(X,P) ; returns external form of action type (350.1), short or long
+1 NEW X1,Y
SET P=$SELECT(+$GET(P):2,1:8)
SET X=+$GET(X)
+2 ;new action type
SET X1=$PIECE($GET(^IBE(350.1,+X,0)),"^",9)
+3 SET Y=$PIECE($GET(^IBE(350.1,+X1,0)),"^",P)
IF Y=""
SET Y=$PIECE($GET(^IBE(350.1,+X,0)),"^",P)
IF Y=""
SET Y=$PIECE($GET(^IBE(350.1,+X,0)),"^")
+4 QUIT Y
