IBTOBI4 ;ALB/AAS - CLAIMS TRACKING BILLING INFORMATION PRINT ; 27-OCT-93
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;
CLIN ; -- output clinical information
N IBOE,DGPM
Q:$D(IBCTHDR)
;
I $P(IBETYP,"^",3)=1 S DGPM=$P(^IBT(356,+IBTRN,0),"^",5) I 'DGPM Q
I $P(IBETYP,"^",3)=2 S IBOE=$P(^IBT(356,+IBTRN,0),"^",4)
F IBTAG="DIAG","PROC","PROV" D @IBTAG Q:IBQUIT
Q
;
DIAG ; -- print diagnosis information
I '$G(DGPM),('$G(IBOE)) Q
Q:$P(IBETYP,"^",3)>2
I ($Y+9)>IOSL D HDR^IBTOBI Q:IBQUIT
DIAG1 W !," Diagnosis Information "
N IBXY,SDDXY
I $G(DGPM) D SET^IBTRE3(+IBTRN) W:'$D(IBXY) !?6,"Nothing on File" D:$D(IBXY) LIST^IBTRE3(.IBXY)
I $G(IBOE) D SET^SDCO4(IBOE) W:'$D(SDDXY) !?6,"Nothing on File" D:$D(SDDXY) LIST^SDCO4(.SDDXY)
;
D:$G(DGPM) DRG
W:'IBQUIT !?4,$TR($J(" ",IOM-8)," ","-"),!
Q
;
PROC ; -- print procedure information
Q:$P(IBETYP,"^",3)>2
I ($Y+9)>IOSL D HDR^IBTOBI Q:IBQUIT
PROC1 W !," Procedure Information "
;
N IBXY,IBCNT S IBCNT=0
I $G(DGPM) D SET^IBTRE4(+IBTRN) W:'$D(IBXY) !?6,"Nothing on File" D:$D(IBXY) LIST^IBTRE4(.IBXY)
I '$G(DGPM) D W:'$D(IBXY) !?6,"Nothing on File" D:$D(IBXY) LIST(.IBXY)
.S IBDT=$P($P(IBTRND,"^",6),"."),IBI=IBDT-.000001
.F S IBI=$O(^SDV("C",DFN,IBI)) Q:'IBI!(IBI>(IBDT+.25)) D
..S IBCS=0 F S IBCS=$O(^SDV(IBI,"CS",IBCS)) Q:'IBCS I $D(^SDV(IBI,"CS",IBCS,"PR")) S IBPR=^("PR") D
...F IBJ=1:1:5 I $P(IBPR,"^",IBJ) S IBCNT=IBCNT+1,IBXY(IBCNT)=$P(IBPR,"^",IBJ)_"^"_IBI
W:'IBQUIT !?4,$TR($J(" ",IOM-8)," ","-"),!
Q
;
PROV ; -- print provider information
I '$G(DGPM),('$G(IBOE)) Q
Q:$P(IBETYP,"^",3)>2
I ($Y+9)>IOSL D HDR^IBTOBI Q:IBQUIT
PROV1 W !," Provider Information "
N IBXY,SDPRY
I $G(DGPM) D SET^IBTRE5(+IBTRN) W:'$D(IBXY) !?6,"Nothing on File" D:$D(IBXY) LIST^IBTRE5(.IBXY)
I $G(IBOE) D SET^SDCO3(IBOE) W:'$D(SDPRY) !?6,"Nothing on File" D:$D(SDPRY) LIST^SDCO3(.SDPRY)
W:'IBQUIT !?4,$TR($J(" ",IOM-8)," ","-"),!
Q
;
LIST(IBXY) ; -- list procedures array
; Input -- IBXY Diagnosis Array Subscripted by a Number
; Output -- List Diagnosis Array
N I,IBXD
W !
S I=0 F S I=$O(IBXY(I)) Q:'I S IBXD=$G(^ICPT(+IBXY(I),0)) D
.W !?2,I," ",$P(IBXD,"^"),?15,$E($P(IBXD,"^",2),1,40),?60,$$DAT1^IBOUTL($P(IBXY(I),"^",2),"2P")
Q
;
DRG ; -- print drgs.
I '$G(DGPM) Q
Q:$P(IBETYP,"^",3)>1
I ($Y+9)>IOSL D HDR^IBTOBI Q:IBQUIT
DRG1 W !!," Associated Interim DRG Information "
N IBX,IBDTE,IBDRG
I $G(DGPM) D
.I '$O(^IBT(356.93,"AMVD",DGPM,0)) W !?6,"Nothing on File" Q
.S IBDTE=0 F S IBDTE=$O(^IBT(356.93,"AMVD",DGPM,IBDTE)) Q:'IBDTE S IBDRG=0 F S IBDRG=$O(^IBT(356.93,"AMVD",DGPM,IBDTE,IBDRG)) Q:'IBDRG D
..S IBX=$G(^IBT(356.93,IBDRG,0)) Q:IBX=""
..W !?5,$$DAT1^IBOUTL($P(IBX,"^",3)),?16,+IBX," - ",$G(^ICD(+IBX,1,1,0))
..W !?21," Estimate ALOS: "_$J($P(IBX,"^",4),4,1)
..W ?45," Days Remaining: "_$J($P(IBX,"^",5),2)
Q
;
4 ; -- Visit region for prosthetics
N IBDA,IBRMPR S IBDA=$P(IBTRND,"^",9) D PRODATA^IBTUTL1(IBDA)
S IBD(2,1)=" Item: "_$G(IBRMPR(660,+IBDA,4,"E"))
S IBD(3,1)=" Description: "_$G(IBRMPR(660,+IBDA,24,"E"))
S IBD(4,1)=" Quantity: "_$J($G(IBRMPR(660,+IBDA,5,"E")),4)
S IBD(5,1)=" Total Cost: $"_$G(IBRMPR(660,+IBDA,14,"E"))
S IBD(6,1)=" Transaction: "_$G(IBRMPR(660,+IBDA,2,"E"))
S IBD(7,1)=" Vendor: "_$G(IBRMPR(660,+IBDA,7,"E"))
S IBD(8,1)=" Source: "_$G(IBRMPR(660,+IBDA,12,"E"))
S IBD(9,1)=" Delivery Date: "_$G(IBRMPR(660,+IBDA,10,"E"))
S IBD(10,1)=" Remarks: "_$G(IBRMPR(660,+IBDA,16,"E"))
S IBD(11,1)=" Return Status: "_$G(IBRMPR(660,+IBDA,17,"E"))
Q
IBTOBI4 ;ALB/AAS - CLAIMS TRACKING BILLING INFORMATION PRINT ; 27-OCT-93
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;
CLIN ; -- output clinical information
+1 NEW IBOE,DGPM
+2 IF $DATA(IBCTHDR)
QUIT
+3 ;
+4 IF $PIECE(IBETYP,"^",3)=1
SET DGPM=$PIECE(^IBT(356,+IBTRN,0),"^",5)
IF 'DGPM
QUIT
+5 IF $PIECE(IBETYP,"^",3)=2
SET IBOE=$PIECE(^IBT(356,+IBTRN,0),"^",4)
+6 FOR IBTAG="DIAG","PROC","PROV"
DO @IBTAG
IF IBQUIT
QUIT
+7 QUIT
+8 ;
DIAG ; -- print diagnosis information
+1 IF '$GET(DGPM)
IF ('$GET(IBOE))
QUIT
+2 IF $PIECE(IBETYP,"^",3)>2
QUIT
+3 IF ($Y+9)>IOSL
DO HDR^IBTOBI
IF IBQUIT
QUIT
DIAG1 WRITE !," Diagnosis Information "
+1 NEW IBXY,SDDXY
+2 IF $GET(DGPM)
DO SET^IBTRE3(+IBTRN)
IF '$DATA(IBXY)
WRITE !?6,"Nothing on File"
IF $DATA(IBXY)
DO LIST^IBTRE3(.IBXY)
+3 IF $GET(IBOE)
DO SET^SDCO4(IBOE)
IF '$DATA(SDDXY)
WRITE !?6,"Nothing on File"
IF $DATA(SDDXY)
DO LIST^SDCO4(.SDDXY)
+4 ;
+5 IF $GET(DGPM)
DO DRG
+6 IF 'IBQUIT
WRITE !?4,$TRANSLATE($JUSTIFY(" ",IOM-8)," ","-"),!
+7 QUIT
+8 ;
PROC ; -- print procedure information
+1 IF $PIECE(IBETYP,"^",3)>2
QUIT
+2 IF ($Y+9)>IOSL
DO HDR^IBTOBI
IF IBQUIT
QUIT
PROC1 WRITE !," Procedure Information "
+1 ;
+2 NEW IBXY,IBCNT
SET IBCNT=0
+3 IF $GET(DGPM)
DO SET^IBTRE4(+IBTRN)
IF '$DATA(IBXY)
WRITE !?6,"Nothing on File"
IF $DATA(IBXY)
DO LIST^IBTRE4(.IBXY)
+4 IF '$GET(DGPM)
Begin DoDot:1
+5 SET IBDT=$PIECE($PIECE(IBTRND,"^",6),".")
SET IBI=IBDT-.000001
+6 FOR
SET IBI=$ORDER(^SDV("C",DFN,IBI))
IF 'IBI!(IBI>(IBDT+.25))
QUIT
Begin DoDot:2
+7 SET IBCS=0
FOR
SET IBCS=$ORDER(^SDV(IBI,"CS",IBCS))
IF 'IBCS
QUIT
IF $DATA(^SDV(IBI,"CS",IBCS,"PR"))
SET IBPR=^("PR")
Begin DoDot:3
+8 FOR IBJ=1:1:5
IF $PIECE(IBPR,"^",IBJ)
SET IBCNT=IBCNT+1
SET IBXY(IBCNT)=$PIECE(IBPR,"^",IBJ)_"^"_IBI
End DoDot:3
End DoDot:2
End DoDot:1
IF '$DATA(IBXY)
WRITE !?6,"Nothing on File"
IF $DATA(IBXY)
DO LIST(.IBXY)
+9 IF 'IBQUIT
WRITE !?4,$TRANSLATE($JUSTIFY(" ",IOM-8)," ","-"),!
+10 QUIT
+11 ;
PROV ; -- print provider information
+1 IF '$GET(DGPM)
IF ('$GET(IBOE))
QUIT
+2 IF $PIECE(IBETYP,"^",3)>2
QUIT
+3 IF ($Y+9)>IOSL
DO HDR^IBTOBI
IF IBQUIT
QUIT
PROV1 WRITE !," Provider Information "
+1 NEW IBXY,SDPRY
+2 IF $GET(DGPM)
DO SET^IBTRE5(+IBTRN)
IF '$DATA(IBXY)
WRITE !?6,"Nothing on File"
IF $DATA(IBXY)
DO LIST^IBTRE5(.IBXY)
+3 IF $GET(IBOE)
DO SET^SDCO3(IBOE)
IF '$DATA(SDPRY)
WRITE !?6,"Nothing on File"
IF $DATA(SDPRY)
DO LIST^SDCO3(.SDPRY)
+4 IF 'IBQUIT
WRITE !?4,$TRANSLATE($JUSTIFY(" ",IOM-8)," ","-"),!
+5 QUIT
+6 ;
LIST(IBXY) ; -- list procedures array
+1 ; Input -- IBXY Diagnosis Array Subscripted by a Number
+2 ; Output -- List Diagnosis Array
+3 NEW I,IBXD
+4 WRITE !
+5 SET I=0
FOR
SET I=$ORDER(IBXY(I))
IF 'I
QUIT
SET IBXD=$GET(^ICPT(+IBXY(I),0))
Begin DoDot:1
+6 WRITE !?2,I," ",$PIECE(IBXD,"^"),?15,$EXTRACT($PIECE(IBXD,"^",2),1,40),?60,$$DAT1^IBOUTL($PIECE(IBXY(I),"^",2),"2P")
End DoDot:1
+7 QUIT
+8 ;
DRG ; -- print drgs.
+1 IF '$GET(DGPM)
QUIT
+2 IF $PIECE(IBETYP,"^",3)>1
QUIT
+3 IF ($Y+9)>IOSL
DO HDR^IBTOBI
IF IBQUIT
QUIT
DRG1 WRITE !!," Associated Interim DRG Information "
+1 NEW IBX,IBDTE,IBDRG
+2 IF $GET(DGPM)
Begin DoDot:1
+3 IF '$ORDER(^IBT(356.93,"AMVD",DGPM,0))
WRITE !?6,"Nothing on File"
QUIT
+4 SET IBDTE=0
FOR
SET IBDTE=$ORDER(^IBT(356.93,"AMVD",DGPM,IBDTE))
IF 'IBDTE
QUIT
SET IBDRG=0
FOR
SET IBDRG=$ORDER(^IBT(356.93,"AMVD",DGPM,IBDTE,IBDRG))
IF 'IBDRG
QUIT
Begin DoDot:2
+5 SET IBX=$GET(^IBT(356.93,IBDRG,0))
IF IBX=""
QUIT
+6 WRITE !?5,$$DAT1^IBOUTL($PIECE(IBX,"^",3)),?16,+IBX," - ",$GET(^ICD(+IBX,1,1,0))
+7 WRITE !?21," Estimate ALOS: "_$JUSTIFY($PIECE(IBX,"^",4),4,1)
+8 WRITE ?45," Days Remaining: "_$JUSTIFY($PIECE(IBX,"^",5),2)
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
4 ; -- Visit region for prosthetics
+1 NEW IBDA,IBRMPR
SET IBDA=$PIECE(IBTRND,"^",9)
DO PRODATA^IBTUTL1(IBDA)
+2 SET IBD(2,1)=" Item: "_$GET(IBRMPR(660,+IBDA,4,"E"))
+3 SET IBD(3,1)=" Description: "_$GET(IBRMPR(660,+IBDA,24,"E"))
+4 SET IBD(4,1)=" Quantity: "_$JUSTIFY($GET(IBRMPR(660,+IBDA,5,"E")),4)
+5 SET IBD(5,1)=" Total Cost: $"_$GET(IBRMPR(660,+IBDA,14,"E"))
+6 SET IBD(6,1)=" Transaction: "_$GET(IBRMPR(660,+IBDA,2,"E"))
+7 SET IBD(7,1)=" Vendor: "_$GET(IBRMPR(660,+IBDA,7,"E"))
+8 SET IBD(8,1)=" Source: "_$GET(IBRMPR(660,+IBDA,12,"E"))
+9 SET IBD(9,1)=" Delivery Date: "_$GET(IBRMPR(660,+IBDA,10,"E"))
+10 SET IBD(10,1)=" Remarks: "_$GET(IBRMPR(660,+IBDA,16,"E"))
+11 SET IBD(11,1)=" Return Status: "_$GET(IBRMPR(660,+IBDA,17,"E"))
+12 QUIT
