source: FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBTOBI4.m@ 1499

Last change on this file since 1499 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 4.3 KB
Line 
1IBTOBI4 ;ALB/AAS - CLAIMS TRACKING BILLING INFORMATION PRINT ;27-OCT-93
2 ;;2.0;INTEGRATED BILLING;**91,125,51,210,266,389**;21-MAR-94;Build 6
3 ;
4CLIN ; -- 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 ;
13DIAG ; -- 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
17DIAG1 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 ;
26PROC ; -- print procedure information
27 Q:$P(IBETYP,"^",3)>2
28 I ($Y+9)>IOSL D HDR^IBTOBI Q:IBQUIT
29PROC1 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 ;
44GETPROC(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 ;
55PROV ; -- 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
59PROV1 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 ;
66LIST(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 ;
79DRG ; -- print drgs.
80 I '$G(DGPM) Q
81 Q:$P(IBETYP,"^",3)>1
82 I ($Y+9)>IOSL D HDR^IBTOBI Q:IBQUIT
83DRG1 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 ;
944 ; -- Visit region for prosthetics
95 N IBDA,IBRMPR S IBDA=$P(IBTRND,"^",9) D PRODATA^IBTUTL1(IBDA)
96 S IBD(2,1)=" Item: "_$P($$PIN^IBCSC5B(+IBDA),U,2)
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 TracBrowser for help on using the repository browser.