- 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 Jan 18, 2025@03:28:25 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