IBTOBI4 ;ALB/AAS - CLAIMS TRACKING BILLING INFORMATION PRINT ;27-OCT-93
;;2.0;INTEGRATED BILLING;**91,125,51,210,266,389,461**;21-MAR-94;Build 58
;
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,IBSDX,ICDVDT
I $G(DGPM) D SET^IBTRE3(+IBTRN) W:'$D(IBXY) !?6,"Nothing on File" D:$D(IBXY) LIST^IBTRE3(.IBXY)
I $G(IBOE) D SETSDX^IBTRE6(+IBOE,.IBSDX) W:'$G(IBSDX) !?6,"Nothing on File" I +$G(IBSDX) S ICDVDT=$$TRNDATE^IBACSV(+IBTRN) D LSTSDX^IBTRE6(.IBSDX)
;
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,IBVAL,IBCBK 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),".")
.;
.S IBVAL("DFN")=DFN,IBVAL("BDT")=IBDT-.000001,IBVAL("EDT")=IBDT\1_".99"
.; Only want to extract procedures from parent encounters to avoid dups
.S IBCBK="I '$P(Y0,U,6) D GETPROC^IBTOBI4(Y,Y0,.IBCNT,.IBXY)"
.D SCAN^IBSDU("PATIENT/DATE",.IBVAL,"",IBCBK) K ^TMP("DIERR",$J)
;
W:'IBQUIT !?4,$TR($J(" ",IOM-8)," ","-"),!
Q
;
GETPROC(IBOE,IBOE0,IBCNT,IBXY) ; output: IBXY(cnt) = CPT IFN ^ DT/TM ^ Mod,Mod ^ Encounter Provider (#1204)
N I2,IBCPT,IBCPTS,IBZERR,IBM,IBMODS
D GETCPT^SDOE(IBOE,"IBCPTS","IBZERR")
Q:'$O(IBCPTS(0)) ;No procedures for this encounter
S I2=0
F S I2=$O(IBCPTS(I2)) Q:'I2 F Z=1:1:$P(IBCPTS(I2),U,16) D
. S IBMODS="",IBM=0
. F S IBM=$O(IBCPTS(I2,1,IBM)) Q:'IBM S IBMODS=$S(IBMODS="":"",1:",")_$G(IBCPTS(I2,1,IBM,0))
. S IBCNT=IBCNT+1,IBXY(IBCNT)=$P(IBCPTS(I2),U)_U_+IBOE0_U_IBMODS_U_$P($G(IBCPTS(I2,12)),U,4)
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,IBSDV
I $G(DGPM) D SET^IBTRE5(+IBTRN) W:'$D(IBXY) !?6,"Nothing on File" D:$D(IBXY) LIST^IBTRE5(.IBXY)
I $G(IBOE) D SETSDV^IBTRE6(+IBOE,.IBSDV) W:'$G(IBSDV) !?6,"Nothing on File" D:+$G(IBSDV) LSTSDV^IBTRE6(.IBSDV)
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,IBMODS,J,IBM,IBDATE
W !
S I=0 F S I=$O(IBXY(I)) Q:'I D
. S IBDATE=$P(IBXY(I),U,2)
. S IBXD=$$PRCD^IBCEF1(+IBXY(I)_";ICPT(",1,IBDATE)
. W !?2,I," ",$P(IBXD,U,2),?15,$E($P(IBXD,U,3),1,40),?60,$$DAT1^IBOUTL(IBDATE,"2P")
. S IBMODS=$$MODLST^IBEFUNC2($P(IBXY(I),U,3),1,.IBMODS,IBDATE)
. I IBMODS'="" F J=1:1:$L(IBMODS,",") W !,?15,$P(IBMODS,",",J),?20,$P($G(IBMODS(1)),",",J)
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," - ",$$DRGTD^IBACSV(+IBX,$P(IBX,"^",3))
..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: "_$P($$PIN^IBCSC5B(+IBDA),U,2)
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBTOBI4 4525 printed Dec 13, 2024@02:27:13 Page 2
IBTOBI4 ;ALB/AAS - CLAIMS TRACKING BILLING INFORMATION PRINT ;27-OCT-93
+1 ;;2.0;INTEGRATED BILLING;**91,125,51,210,266,389,461**;21-MAR-94;Build 58
+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,IBSDX,ICDVDT
+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 SETSDX^IBTRE6(+IBOE,.IBSDX)
if '$GET(IBSDX)
WRITE !?6,"Nothing on File"
IF +$GET(IBSDX)
SET ICDVDT=$$TRNDATE^IBACSV(+IBTRN)
DO LSTSDX^IBTRE6(.IBSDX)
+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,IBVAL,IBCBK
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),".")
+6 ;
+7 SET IBVAL("DFN")=DFN
SET IBVAL("BDT")=IBDT-.000001
SET IBVAL("EDT")=IBDT\1_".99"
+8 ; Only want to extract procedures from parent encounters to avoid dups
+9 SET IBCBK="I '$P(Y0,U,6) D GETPROC^IBTOBI4(Y,Y0,.IBCNT,.IBXY)"
+10 DO SCAN^IBSDU("PATIENT/DATE",.IBVAL,"",IBCBK)
KILL ^TMP("DIERR",$JOB)
End DoDot:1
if '$DATA(IBXY)
WRITE !?6,"Nothing on File"
if $DATA(IBXY)
DO LIST(.IBXY)
+11 ;
+12 if 'IBQUIT
WRITE !?4,$TRANSLATE($JUSTIFY(" ",IOM-8)," ","-"),!
+13 QUIT
+14 ;
GETPROC(IBOE,IBOE0,IBCNT,IBXY) ; output: IBXY(cnt) = CPT IFN ^ DT/TM ^ Mod,Mod ^ Encounter Provider (#1204)
+1 NEW I2,IBCPT,IBCPTS,IBZERR,IBM,IBMODS
+2 DO GETCPT^SDOE(IBOE,"IBCPTS","IBZERR")
+3 ;No procedures for this encounter
if '$ORDER(IBCPTS(0))
QUIT
+4 SET I2=0
+5 FOR
SET I2=$ORDER(IBCPTS(I2))
if 'I2
QUIT
FOR Z=1:1:$PIECE(IBCPTS(I2),U,16)
Begin DoDot:1
+6 SET IBMODS=""
SET IBM=0
+7 FOR
SET IBM=$ORDER(IBCPTS(I2,1,IBM))
if 'IBM
QUIT
SET IBMODS=$SELECT(IBMODS="":"",1:",")_$GET(IBCPTS(I2,1,IBM,0))
+8 SET IBCNT=IBCNT+1
SET IBXY(IBCNT)=$PIECE(IBCPTS(I2),U)_U_+IBOE0_U_IBMODS_U_$PIECE($GET(IBCPTS(I2,12)),U,4)
End DoDot:1
+9 QUIT
+10 ;
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,IBSDV
+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 SETSDV^IBTRE6(+IBOE,.IBSDV)
if '$GET(IBSDV)
WRITE !?6,"Nothing on File"
if +$GET(IBSDV)
DO LSTSDV^IBTRE6(.IBSDV)
+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,IBMODS,J,IBM,IBDATE
+4 WRITE !
+5 SET I=0
FOR
SET I=$ORDER(IBXY(I))
if 'I
QUIT
Begin DoDot:1
+6 SET IBDATE=$PIECE(IBXY(I),U,2)
+7 SET IBXD=$$PRCD^IBCEF1(+IBXY(I)_";ICPT(",1,IBDATE)
+8 WRITE !?2,I," ",$PIECE(IBXD,U,2),?15,$EXTRACT($PIECE(IBXD,U,3),1,40),?60,$$DAT1^IBOUTL(IBDATE,"2P")
+9 SET IBMODS=$$MODLST^IBEFUNC2($PIECE(IBXY(I),U,3),1,.IBMODS,IBDATE)
+10 IF IBMODS'=""
FOR J=1:1:$LENGTH(IBMODS,",")
WRITE !,?15,$PIECE(IBMODS,",",J),?20,$PIECE($GET(IBMODS(1)),",",J)
End DoDot:1
+11 QUIT
+12 ;
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," - ",$$DRGTD^IBACSV(+IBX,$PIECE(IBX,"^",3))
+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: "_$PIECE($$PIN^IBCSC5B(+IBDA),U,2)
+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
