source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCOPV2.m@ 862

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

initial load of WorldVistAEHR

File size: 1.4 KB
RevLine 
[613]1IBCOPV2 ;ALB/LDB - ROUTINE TO LIST PATIENT VISITS ;30 APR 90
2 ;;2.0;INTEGRATED BILLING;**52,91,106**;21-MAR-94
3 ;
4 ;MAP TO DGCROPV2
5 ;
6ELIG N IBCODN
7 Q:$D(DGNO) S (DGCOD,IBCODN)=$S(DGFIL'=2.101:+$P(DGNOD,U,3),1:"ADMITTING/SCREENING") I $D(^DIC(40.7,+IBCODN,0)) S:IBCODN DGCOD=$P(^DIC(40.7,+IBCODN,0),U)
8 I DGFIL=409.5,$P($G(^DIC(40.7,+IBCODN,0)),U,2)>899&($P($G(^DIC(40.7,+IBCODN,0)),U,2)<999) S DGCOD=$P(DGNOD,U,4) S:$D(^SC(+DGCOD,0)) DGCOD=$P(^(0),U,7) S:$D(^DIC(40.7,+DGCOD,0)) DGCOD=$P(^(0),U)
9 I DGFIL'=2.101 S IBCODCL=$P(DGNOD,U,4) S IBCODCL=$P($G(^SC(+IBCODCL,0)),U,1)
10 ;
11 I (DGTYP="")!(DGTYP=9) S DGTYP=$S($D(^DPT(DFN,.36)):^(.36),1:"") S:DGTYP DGTYP=$E($G(^DIC(8,+DGTYP,0)),1,3)
12 I DGTYP'="NSC" S DGMT="" Q
13 S DGMT=$P($$LST^DGMTU(DFN,$P(I,".",1)),U,4)
14 Q
15 ;
16CHG S IBCHG=+$$BILLCOST^IBCRCI(IBIFN,DGDT,"OUTPATIENT VISIT DATE")
17 I +IBCHG S $P(^UTILITY($J,"OPV","AP",DGCNT),U,2)=IBCHG
18 Q
19 ;
20PROD F P=2:1 S DGCPT2=$P(^UTILITY($J,"CPT1",I7,DGNO),U,P) Q:DGCPT2="" D
21 .I $P(^DGCR(399,IBIFN,0),U,9)=4 D
22 ..F I8=1:1:3 I $P($G(^DGCR(399,IBIFN,"C")),U,I8)=$P(^UTILITY($J,"CPT1",I7,DGNO),U,P) S $P(^UTILITY($J,"CPT1",I7,DGNO),U,P)=$P(^UTILITY($J,"CPT1",I7,DGNO),U,P)_"~0"
23 .I $D(^DGCR(399,IBIFN,"CP","B",DGCPT2_";ICPT(")) D
24 ..F DGCPT0=0:0 S DGCPT0=$O(^DGCR(399,IBIFN,"CP","B",DGCPT2_";ICPT(",DGCPT0)) Q:'DGCPT0 D
25 ...S $P(^UTILITY($J,"CPT1",I7,DGNO),U,P)=$S(^UTILITY($J,"CPT1",I7,DGNO)'[(DGCPT2_"~"_DGCPT0):(DGCPT2_"~"_DGCPT0),1:$P(^UTILITY($J,"CPT",I7,DGNO),U,P))
26 Q
27 ;
Note: See TracBrowser for help on using the repository browser.