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

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

initial load of FOIAVistA 6/30/08 version

File size: 4.8 KB
Line 
1IBNCPDPH ;DALOI/SS - ECME REPORT OF ON HOLD CHARGES FOR A PATIENT ;JUNE 08 2005
2 ;;2.0;INTEGRATED BILLING;**276,347**;21-MAR-94;Build 24
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 Q
5 ;
6 ;made after IBOHPT1 to use with ECME User Screen
7 ;see IA# with ECME
8 ;
9ONHOLD(DFN) ;
10 Q:$$PFSSON^IBNCPDPI() ;quit if PFSS is ON
11 N IBQUIT,IBII,DIRUT,DUOUT,DTOUT,ZTIO,Y S IBQUIT=0
12 N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy lookups
13 ;
14 S DIR(0)="DA^::EX",DIR("A")="Start with DATE: "
15 S DIR("?")="Enter the starting date for this report."
16 D ^DIR K DIR G:$D(DIRUT) EXIT S IBSDT=+Y
17 S DIR(0)="DA^"_+Y_":NOW:EX",DIR("A")=" Go to DATE: "
18 S DIR("?")="Enter the ending date for this report."
19 D ^DIR K DIR G:$D(DIRUT) EXIT S IBEDT=+Y
20 ;
21 S DIR(0)="Y",DIR("A")="Include Pharmacy Co-pay charges on this report",DIR("B")="NO"
22 S DIR("?",1)=" Enter: 'Y' - to include Pharmacy Co-pay charges on this report"
23 S DIR("?",2)=" 'N' - to exclude Pharmacy Co-pay charges on this report"
24 S DIR("?")=" '^' - to select a new patient"
25 D ^DIR K DIR G:$D(DIRUT) EXIT S IBIBRX=Y
26 ;
27QUEUED ; entry point if queued
28 ;***
29 K ^TMP($J,"IB")
30 D:'$G(IBQUIT) DEVICE D:'$G(IBQUIT) CHRGS,REPORT^IBOHPT2
31 D EXIT
32 ;***
33 Q
34EXIT ;
35 K ^TMP($J,"IB")
36 K DFN,IBEND,IBSDT,IBEDT,IBIBRX,IBCN,IBDT,IBIFN,X
37 K IBRDT,IBRF,IBRX,IBRXN
38 I $D(ZTQUEUED) S ZTREQ="@" Q
39 D ^%ZISC
40 Q
41DEVICE ;
42 I $D(ZTQUEUED) Q
43 W !!,*7,"*** Margin width of this output is 132 ***"
44 W !,"*** This output should be queued ***"
45 N %ZIS
46 S %ZIS="QM" D ^%ZIS I POP S IBQUIT=1 Q
47 N ZTRTN,ZTIO,ZTDES,ZTSAVE
48 I $D(IO("Q")) S ZTRTN="QUEUED^IBOHPT1",ZTIO=ION,ZTDESC="ON HOLD CHARGE INFO/PT",ZTSAVE("IB*")="",ZTSAVE("DFN")="" D ^%ZTLOAD W !,$S($D(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED") D HOME^%ZIS K ZTSK S IBQUIT=1 Q
49 U IO
50 Q
51 ; indexes records that should be included in report
52 ;
53CHRGS ; charges on hold
54 N DATE,IBN,IBND,A,B,C,D,E,IBNX
55 S IBN=0 F S IBN=$O(^IB("C",DFN,IBN)) Q:'IBN S IBND=$G(^IB(IBN,0)) D:IBND
56 .I 'IBIBRX,$E($G(^IBE(350.1,+$P(IBND,"^",3),0)),1,3)="PSO" Q
57 .Q:$P(IBND,"^",8)["ADMISSION"
58 .Q:'$P($G(^IB(IBN,1)),"^",6)
59 .Q:'$D(^IB("APDT",IBN))
60 .S (C,D)="",C=$O(^IB("APDT",IBN,C)),D=$O(^IB("APDT",IBN,C,D))
61 .S E=$P($G(^IB(D,0)),U,3)
62 .S A=$P($G(^IBE(350.1,E,0)),U,5)
63 .S IBNX=$S(A=2:$P($Q(^IB("APDT",IBN,C,D)),")",1),A=3:$P($Q(^IB("APDT",IBN,C,D)),")",1),1:IBN)
64 .I (A=2)!(A=3) D
65 ..I IBNX["[""" S IBNX="^"_$P(IBNX,"]",2)
66 .I $P(IBNX,",",4)>0 S IBNX=$P(IBNX,",",4)
67 .S DATE=$P($G(^IB(+$P(IBND,"^",1),0)),"^",17)
68 .S:'DATE DATE=$P($G(^IB(IBNX,1)),"^",5)
69 .S:'DATE DATE=$P($G(^IB(IBNX,1)),"^",2)\1
70 .I (DATE>(IBSDT-.0001))&(DATE<(IBEDT+.9999)) S ^TMP($J,"IB",-DATE,IBNX)="" D BILLS
71 Q
72 ;
73BILLS ; find bills for charges on hold
74 N IBFR,IBT,IBATYPE,IBTO
75 S IBATYPE=$S($P($G(^IBE(350.1,+$P(IBND,"^",3),0)),"^")["OPT":"O",$P($G(^IBE(350.1,+IBND,"^",3,0)),"^")["PSO":"RX",1:"I")
76 S IBFR=$P(IBND,"^",14),IBTO=$P(IBND,"^",15)
77 I IBATYPE="I" D INP
78 I IBATYPE="O" D OPT
79 E D RX
80 Q
81INP ; inpatient bills
82 N IBEV,IBBILL,IBT,X,X1,X2,IBEND,IBOK
83 S IBEV=$P(IBND,"^",16) Q:'IBEV ; parent event
84 S IBEV=($P($G(^IB(IBEV,0)),"^",17)\1) Q:'IBEV ; date of parent event
85 S X1=IBEV,X2=1 D C^%DTC S IBEND=X
86 S IBT=(IBEV-.0001) F S IBT=$O(^DGCR(399,"D",IBT)) Q:'IBT!(IBT'<IBEND) S IBBILL=0 F S IBBILL=$O(^DGCR(399,"D",IBT,IBBILL)) Q:IBBILL="" D
87 .D INPTCK
88 .I IBOK S ^TMP($J,"IB",-DATE,IBNX,IBBILL)=""
89 Q
90 ;
91INPTCK ; does bill belong to charge? returns IBOK=0 if no
92 N IBBILL0,IBBILLU
93 S IBBILL0=$G(^DGCR(399,IBBILL,0)),IBBILLU=$G(^("U"))
94 S IBOK=1
95CK1 ; for same patient?
96 I DFN=$P(IBBILL0,"^",2)
97 S IBOK=$T
98 Q:'IBOK
99CK2 ; same type- inp or opt?
100 N B S B=$S(+$P(IBBILL0,"^",5)<3:"I",1:"O")
101 I B=IBATYPE
102 S IBOK=$T
103 Q:'IBOK
104CK3 ; overlap in date range?
105 N F,T
106 S F=+IBBILLU,T=$P(IBBILLU,"^",2)
107 I (IBTO<F)!(IBFR>T)
108 S IBOK='$T
109 Q:'IBOK
110CK4 ; insurance bill?
111 I $P(IBBILL0,"^",11)="i"
112 S IBOK=$T
113 Q
114OPT ; outpatient bills
115 N X,IBV,IBBILL,IBOK,IBBILL0
116 S IBV=(IBFR\1)-.0001 F S IBV=$O(^DGCR(399,"AOPV",DFN,IBV)) Q:'IBV!(IBV>IBTO) S IBBILL=0 D
117 .F S IBBILL=$O(^DGCR(399,"AOPV",DFN,IBV,IBBILL)) Q:('IBBILL) D
118 ..Q:$D(^TMP($J,"IB",-DATE,IBNX,IBBILL))
119 ..S IBBILL0=$G(^DGCR(399,IBBILL,0)) D CK4 Q:'IBOK
120 ..S ^TMP($J,"IB",-DATE,IBNX,IBBILL)=""
121 Q
122RX ; rx refill bills
123 Q:'IBIBRX
124 S (IBRX,IBRXN,IBRF,IBRDT)=0
125 I $P(IBND,"^",4)'["52:" Q
126 ;
127 S IBRXN=$P($P(IBND,"^",4),":",2),IBRX=$P($P(IBND,"^",8),"-"),IBRF=$P($P(IBND,"^",4),":",3)
128 ;
129 I +IBRF>0 S IBRDT=$$SUBFILE^IBRXUTL(+IBRXN,IBRF,52,.01)
130 I +IBRF=0 S IBRDT=$$FILE^IBRXUTL(+IBRXN,22)
131 ;
132 Q:(IBRX="")!('IBRDT)
133 N X,IBBILL,IBBILL0,IBFILL,IBFILL0,IBOK S IBBILL=0
134 S IBFILL=0 F S IBFILL=$O(^IBA(362.4,"B",IBRX,IBFILL)) Q:IBFILL="" D
135 .S IBFILL0=$G(^IBA(362.4,IBFILL,0)) I $P(IBFILL0,"^",3)'=IBRDT Q
136 .S IBBILL=+$P(IBFILL0,"^",2) I 'IBBILL Q
137 .S IBBILL0=$G(^DGCR(399,IBBILL,0)) D CK4 I 'IBOK Q
138 .S ^TMP($J,"IB",-DATE,IBNX,IBBILL)=""
139 Q
Note: See TracBrowser for help on using the repository browser.