- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBTOBI4.m
r613 r623 1 IBTOBI4 2 ;;2.0;INTEGRATED BILLING;**91,125,51,210,266,389**;21-MAR-94;Build 6 3 4 CLIN 5 6 7 8 9 10 11 12 13 DIAG 14 15 16 17 DIAG1 18 19 20 21 22 23 24 25 26 PROC 27 28 29 PROC1 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 GETPROC(IBOE,IBOE0,IBCNT,IBXY) 45 46 47 48 49 50 51 52 53 54 55 PROV 56 57 58 59 PROV1 60 61 62 63 64 65 66 LIST(IBXY) 67 68 69 70 71 72 73 74 75 76 77 78 79 DRG 80 81 82 83 DRG1 84 85 86 87 88 89 90 91 92 93 94 4 95 96 S IBD(2,1)=" Item: "_$P($$PIN^IBCSC5B(+IBDA),U,2)97 98 99 100 101 102 103 104 105 106 1 IBTOBI4 ;ALB/AAS - CLAIMS TRACKING BILLING INFORMATION PRINT ;27-OCT-93 2 ;;2.0;INTEGRATED BILLING;**91,125,51,210,266**;21-MAR-94 3 ; 4 CLIN ; -- output clinical information 5 N IBOE,DGPM 6 Q:$D(IBCTHDR) 7 ; 8 I $P(IBETYP,"^",3)=1 S DGPM=$P(^IBT(356,+IBTRN,0),"^",5) I 'DGPM Q 9 I $P(IBETYP,"^",3)=2 S IBOE=$P(^IBT(356,+IBTRN,0),"^",4) 10 F IBTAG="DIAG","PROC","PROV" D @IBTAG Q:IBQUIT 11 Q 12 ; 13 DIAG ; -- print diagnosis information 14 I '$G(DGPM),('$G(IBOE)) Q 15 Q:$P(IBETYP,"^",3)>2 16 I ($Y+9)>IOSL D HDR^IBTOBI Q:IBQUIT 17 DIAG1 W !," Diagnosis Information " 18 N IBXY,SDDXY,ICDVDT 19 I $G(DGPM) D SET^IBTRE3(+IBTRN) W:'$D(IBXY) !?6,"Nothing on File" D:$D(IBXY) LIST^IBTRE3(.IBXY) 20 I $G(IBOE) D SET^SDCO4(IBOE) W:'$D(SDDXY) !?6,"Nothing on File" I $D(SDDXY) S ICDVDT=$$TRNDATE^IBACSV(+IBTRN) D LIST^SDCO4(.SDDXY) 21 ; 22 D:$G(DGPM) DRG 23 W:'IBQUIT !?4,$TR($J(" ",IOM-8)," ","-"),! 24 Q 25 ; 26 PROC ; -- print procedure information 27 Q:$P(IBETYP,"^",3)>2 28 I ($Y+9)>IOSL D HDR^IBTOBI Q:IBQUIT 29 PROC1 W !," Procedure Information " 30 ; 31 N IBXY,IBCNT,IBVAL,IBCBK S IBCNT=0 32 I $G(DGPM) D SET^IBTRE4(+IBTRN) W:'$D(IBXY) !?6,"Nothing on File" D:$D(IBXY) LIST^IBTRE4(.IBXY) 33 I '$G(DGPM) D W:'$D(IBXY) !?6,"Nothing on File" D:$D(IBXY) LIST(.IBXY) 34 .S IBDT=$P($P(IBTRND,"^",6),".") 35 .; 36 .S IBVAL("DFN")=DFN,IBVAL("BDT")=IBDT-.000001,IBVAL("EDT")=IBDT\1_".99" 37 .; Only want to extract procedures from parent encounters to avoid dups 38 .S IBCBK="I '$P(Y0,U,6) D GETPROC^IBTOBI4(Y,Y0,.IBCNT,.IBXY)" 39 .D SCAN^IBSDU("PATIENT/DATE",.IBVAL,"",IBCBK) K ^TMP("DIERR",$J) 40 ; 41 W:'IBQUIT !?4,$TR($J(" ",IOM-8)," ","-"),! 42 Q 43 ; 44 GETPROC(IBOE,IBOE0,IBCNT,IBXY) ; output: IBXY(cnt) = CPT IFN ^ DT/TM ^ Mod,Mod ^ Encounter Provider (#1204) 45 N I2,IBCPT,IBCPTS,IBZERR,IBM,IBMODS 46 D GETCPT^SDOE(IBOE,"IBCPTS","IBZERR") 47 Q:'$O(IBCPTS(0)) ;No procedures for this encounter 48 S I2=0 49 F S I2=$O(IBCPTS(I2)) Q:'I2 F Z=1:1:$P(IBCPTS(I2),U,16) D 50 . S IBMODS="",IBM=0 51 . F S IBM=$O(IBCPTS(I2,1,IBM)) Q:'IBM S IBMODS=$S(IBMODS="":"",1:",")_$G(IBCPTS(I2,1,IBM,0)) 52 . S IBCNT=IBCNT+1,IBXY(IBCNT)=$P(IBCPTS(I2),U)_U_+IBOE0_U_IBMODS_U_$P($G(IBCPTS(I2,12)),U,4) 53 Q 54 ; 55 PROV ; -- print provider information 56 I '$G(DGPM),('$G(IBOE)) Q 57 Q:$P(IBETYP,"^",3)>2 58 I ($Y+9)>IOSL D HDR^IBTOBI Q:IBQUIT 59 PROV1 W !," Provider Information " 60 N IBXY,SDPRY 61 I $G(DGPM) D SET^IBTRE5(+IBTRN) W:'$D(IBXY) !?6,"Nothing on File" D:$D(IBXY) LIST^IBTRE5(.IBXY) 62 I $G(IBOE) D SET^SDCO3(IBOE) W:'$D(SDPRY) !?6,"Nothing on File" D:$D(SDPRY) LIST^SDCO3(.SDPRY) 63 W:'IBQUIT !?4,$TR($J(" ",IOM-8)," ","-"),! 64 Q 65 ; 66 LIST(IBXY) ; -- list procedures array 67 ; Input -- IBXY Diagnosis Array Subscripted by a Number 68 ; Output -- List Diagnosis Array 69 N I,IBXD,IBMODS,J,IBM,IBDATE 70 W ! 71 S I=0 F S I=$O(IBXY(I)) Q:'I D 72 . S IBDATE=$P(IBXY(I),U,2) 73 . S IBXD=$$PRCD^IBCEF1(+IBXY(I)_";ICPT(",1,IBDATE) 74 . W !?2,I," ",$P(IBXD,U,2),?15,$E($P(IBXD,U,3),1,40),?60,$$DAT1^IBOUTL(IBDATE,"2P") 75 . S IBMODS=$$MODLST^IBEFUNC2($P(IBXY(I),U,3),1,.IBMODS,IBDATE) 76 . I IBMODS'="" F J=1:1:$L(IBMODS,",") W !,?15,$P(IBMODS,",",J),?20,$P($G(IBMODS(1)),",",J) 77 Q 78 ; 79 DRG ; -- print drgs. 80 I '$G(DGPM) Q 81 Q:$P(IBETYP,"^",3)>1 82 I ($Y+9)>IOSL D HDR^IBTOBI Q:IBQUIT 83 DRG1 W !!," Associated Interim DRG Information " 84 N IBX,IBDTE,IBDRG 85 I $G(DGPM) D 86 .I '$O(^IBT(356.93,"AMVD",DGPM,0)) W !?6,"Nothing on File" Q 87 .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 88 ..S IBX=$G(^IBT(356.93,IBDRG,0)) Q:IBX="" 89 ..W !?5,$$DAT1^IBOUTL($P(IBX,"^",3)),?16,+IBX," - ",$$DRGTD^IBACSV(+IBX,$P(IBX,"^",3)) 90 ..W !?21," Estimate ALOS: "_$J($P(IBX,"^",4),4,1) 91 ..W ?45," Days Remaining: "_$J($P(IBX,"^",5),2) 92 Q 93 ; 94 4 ; -- Visit region for prosthetics 95 N IBDA,IBRMPR S IBDA=$P(IBTRND,"^",9) D PRODATA^IBTUTL1(IBDA) 96 S IBD(2,1)=" Item: "_$G(IBRMPR(660,+IBDA,4,"E")) 97 S IBD(3,1)=" Description: "_$G(IBRMPR(660,+IBDA,24,"E")) 98 S IBD(4,1)=" Quantity: "_$J($G(IBRMPR(660,+IBDA,5,"E")),4) 99 S IBD(5,1)=" Total Cost: $"_$G(IBRMPR(660,+IBDA,14,"E")) 100 S IBD(6,1)=" Transaction: "_$G(IBRMPR(660,+IBDA,2,"E")) 101 S IBD(7,1)=" Vendor: "_$G(IBRMPR(660,+IBDA,7,"E")) 102 S IBD(8,1)=" Source: "_$G(IBRMPR(660,+IBDA,12,"E")) 103 S IBD(9,1)=" Delivery Date: "_$G(IBRMPR(660,+IBDA,10,"E")) 104 S IBD(10,1)=" Remarks: "_$G(IBRMPR(660,+IBDA,16,"E")) 105 S IBD(11,1)=" Return Status: "_$G(IBRMPR(660,+IBDA,17,"E")) 106 Q
Note:
See TracChangeset
for help on using the changeset viewer.
