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

IBTOBI4.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. CLIN ; -- output clinical information
  1. N IBOE,DGPM
  1. Q:$D(IBCTHDR)
  1. ;
  1. I $P(IBETYP,"^",3)=1 S DGPM=$P(^IBT(356,+IBTRN,0),"^",5) I 'DGPM Q
  1. I $P(IBETYP,"^",3)=2 S IBOE=$P(^IBT(356,+IBTRN,0),"^",4)
  1. F IBTAG="DIAG","PROC","PROV" D @IBTAG Q:IBQUIT
  1. Q
  1. ;
  1. DIAG ; -- print diagnosis information
  1. I '$G(DGPM),('$G(IBOE)) Q
  1. Q:$P(IBETYP,"^",3)>2
  1. I ($Y+9)>IOSL D HDR^IBTOBI Q:IBQUIT
  1. DIAG1 W !," Diagnosis Information "
  1. N IBXY,IBSDX,ICDVDT
  1. I $G(DGPM) D SET^IBTRE3(+IBTRN) W:'$D(IBXY) !?6,"Nothing on File" D:$D(IBXY) LIST^IBTRE3(.IBXY)
  1. 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)
  1. ;
  1. D:$G(DGPM) DRG
  1. W:'IBQUIT !?4,$TR($J(" ",IOM-8)," ","-"),!
  1. Q
  1. ;
  1. PROC ; -- print procedure information
  1. Q:$P(IBETYP,"^",3)>2
  1. I ($Y+9)>IOSL D HDR^IBTOBI Q:IBQUIT
  1. PROC1 W !," Procedure Information "
  1. ;
  1. N IBXY,IBCNT,IBVAL,IBCBK S IBCNT=0
  1. I $G(DGPM) D SET^IBTRE4(+IBTRN) W:'$D(IBXY) !?6,"Nothing on File" D:$D(IBXY) LIST^IBTRE4(.IBXY)
  1. I '$G(DGPM) D W:'$D(IBXY) !?6,"Nothing on File" D:$D(IBXY) LIST(.IBXY)
  1. .S IBDT=$P($P(IBTRND,"^",6),".")
  1. .;
  1. .S IBVAL("DFN")=DFN,IBVAL("BDT")=IBDT-.000001,IBVAL("EDT")=IBDT\1_".99"
  1. .; Only want to extract procedures from parent encounters to avoid dups
  1. .S IBCBK="I '$P(Y0,U,6) D GETPROC^IBTOBI4(Y,Y0,.IBCNT,.IBXY)"
  1. .D SCAN^IBSDU("PATIENT/DATE",.IBVAL,"",IBCBK) K ^TMP("DIERR",$J)
  1. ;
  1. W:'IBQUIT !?4,$TR($J(" ",IOM-8)," ","-"),!
  1. Q
  1. ;
  1. GETPROC(IBOE,IBOE0,IBCNT,IBXY) ; output: IBXY(cnt) = CPT IFN ^ DT/TM ^ Mod,Mod ^ Encounter Provider (#1204)
  1. N I2,IBCPT,IBCPTS,IBZERR,IBM,IBMODS
  1. D GETCPT^SDOE(IBOE,"IBCPTS","IBZERR")
  1. Q:'$O(IBCPTS(0)) ;No procedures for this encounter
  1. S I2=0
  1. F S I2=$O(IBCPTS(I2)) Q:'I2 F Z=1:1:$P(IBCPTS(I2),U,16) D
  1. . S IBMODS="",IBM=0
  1. . F S IBM=$O(IBCPTS(I2,1,IBM)) Q:'IBM S IBMODS=$S(IBMODS="":"",1:",")_$G(IBCPTS(I2,1,IBM,0))
  1. . S IBCNT=IBCNT+1,IBXY(IBCNT)=$P(IBCPTS(I2),U)_U_+IBOE0_U_IBMODS_U_$P($G(IBCPTS(I2,12)),U,4)
  1. Q
  1. ;
  1. PROV ; -- print provider information
  1. I '$G(DGPM),('$G(IBOE)) Q
  1. Q:$P(IBETYP,"^",3)>2
  1. I ($Y+9)>IOSL D HDR^IBTOBI Q:IBQUIT
  1. PROV1 W !," Provider Information "
  1. N IBXY,IBSDV
  1. I $G(DGPM) D SET^IBTRE5(+IBTRN) W:'$D(IBXY) !?6,"Nothing on File" D:$D(IBXY) LIST^IBTRE5(.IBXY)
  1. I $G(IBOE) D SETSDV^IBTRE6(+IBOE,.IBSDV) W:'$G(IBSDV) !?6,"Nothing on File" D:+$G(IBSDV) LSTSDV^IBTRE6(.IBSDV)
  1. W:'IBQUIT !?4,$TR($J(" ",IOM-8)," ","-"),!
  1. Q
  1. ;
  1. LIST(IBXY) ; -- list procedures array
  1. ; Input -- IBXY Diagnosis Array Subscripted by a Number
  1. ; Output -- List Diagnosis Array
  1. N I,IBXD,IBMODS,J,IBM,IBDATE
  1. W !
  1. S I=0 F S I=$O(IBXY(I)) Q:'I D
  1. . S IBDATE=$P(IBXY(I),U,2)
  1. . S IBXD=$$PRCD^IBCEF1(+IBXY(I)_";ICPT(",1,IBDATE)
  1. . W !?2,I," ",$P(IBXD,U,2),?15,$E($P(IBXD,U,3),1,40),?60,$$DAT1^IBOUTL(IBDATE,"2P")
  1. . S IBMODS=$$MODLST^IBEFUNC2($P(IBXY(I),U,3),1,.IBMODS,IBDATE)
  1. . I IBMODS'="" F J=1:1:$L(IBMODS,",") W !,?15,$P(IBMODS,",",J),?20,$P($G(IBMODS(1)),",",J)
  1. Q
  1. ;
  1. DRG ; -- print drgs.
  1. I '$G(DGPM) Q
  1. Q:$P(IBETYP,"^",3)>1
  1. I ($Y+9)>IOSL D HDR^IBTOBI Q:IBQUIT
  1. DRG1 W !!," Associated Interim DRG Information "
  1. N IBX,IBDTE,IBDRG
  1. I $G(DGPM) D
  1. .I '$O(^IBT(356.93,"AMVD",DGPM,0)) W !?6,"Nothing on File" Q
  1. .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
  1. ..S IBX=$G(^IBT(356.93,IBDRG,0)) Q:IBX=""
  1. ..W !?5,$$DAT1^IBOUTL($P(IBX,"^",3)),?16,+IBX," - ",$$DRGTD^IBACSV(+IBX,$P(IBX,"^",3))
  1. ..W !?21," Estimate ALOS: "_$J($P(IBX,"^",4),4,1)
  1. ..W ?45," Days Remaining: "_$J($P(IBX,"^",5),2)
  1. Q
  1. ;
  1. 4 ; -- Visit region for prosthetics
  1. N IBDA,IBRMPR S IBDA=$P(IBTRND,"^",9) D PRODATA^IBTUTL1(IBDA)
  1. S IBD(2,1)=" Item: "_$P($$PIN^IBCSC5B(+IBDA),U,2)
  1. S IBD(3,1)=" Description: "_$G(IBRMPR(660,+IBDA,24,"E"))
  1. S IBD(4,1)=" Quantity: "_$J($G(IBRMPR(660,+IBDA,5,"E")),4)
  1. S IBD(5,1)=" Total Cost: $"_$G(IBRMPR(660,+IBDA,14,"E"))
  1. S IBD(6,1)=" Transaction: "_$G(IBRMPR(660,+IBDA,2,"E"))
  1. S IBD(7,1)=" Vendor: "_$G(IBRMPR(660,+IBDA,7,"E"))
  1. S IBD(8,1)=" Source: "_$G(IBRMPR(660,+IBDA,12,"E"))
  1. S IBD(9,1)=" Delivery Date: "_$G(IBRMPR(660,+IBDA,10,"E"))
  1. S IBD(10,1)=" Remarks: "_$G(IBRMPR(660,+IBDA,16,"E"))
  1. S IBD(11,1)=" Return Status: "_$G(IBRMPR(660,+IBDA,17,"E"))
  1. Q