source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCU4.m

IBCU4 ;ALB/AAS - BILLING UTILITY ROUTINE (CONTINUED) ; 12-FEB-90
 ;;2.0;INTEGRATED BILLING;**109,122,137,245,349**;21-MAR-94;Build 46
 ;;Per VHA Directive 2004-038, this routine should not be modified.
 ;
 ;MAP TO DGCRU4
 ;
DDAT ;Input transform for Statement Covers From field
 I '$D(DA) G TO
 S IB00=+$P(^DGCR(399,+DA,0),"^",3) I +X<$P(IB00,".",1) W !?4,"Cannot precede the 'EVENT DATE'!",*7 K X G DDAT4
 I +X>(DT_".2359") W !?4,"Cannot bill for future treatment!",*7 K X G DDAT4
 D PROCDT
 I DGPRDTB,X>DGPRDTB K X W !?4,"Can't be greater than date of specified Procedures!",*7 G DDAT4
 G DDAT4
DDAT1 ;Input transform for Statement covers to
 I '$D(DA) G FROM
 S IB00=$S($D(^DGCR(399,+DA,"U")):$P(^("U"),"^",1),1:"") I 'IB00 W !?4,"'Start Date' must be specified first!",*7 K X G DDAT4
 I +X>DT W !?4,"Cannot bill for future treatment!",*7 K X G DDAT4
 I +X<IB00 W !?4,"Cannot preceed the 'Start Date'!",*7 K X G DDAT4
 ;I $S($E(IB00,4,5)<10:$E(IB00,2,3),1:$E(IB00,2,3)+1)'=$S($E(X,4,5)<10:$E(X,2,3),1:$E(X,2,3)+1) K X W !?4,"Must be in same fiscal year!",*7 G DDAT4
 ;I $$FY(+IB00)'=$$FY(X) K X W !?4,"Must be in same fiscal year!",*7 G DDAT4
 ;I $E(IB00,1,3)'=$E(X,1,3) K X W !?4,"Must be in same calendar year!",*7 G DDAT4
 D PROCDT
 I DGPRDTE,X<DGPRDTE K X W !?4,"Can't be less than date of specified Procedures!",*7 G DDAT4
 G DDAT4
 ;
 ;DDAT2   ;Input transform for OP VISITS DATE(S) field  REPLACED WITH IBCU41 6/15/93
 ;S IB00=$G(^DGCR(399,IBIFN,"U")) I $P(IB00,"^",1)']"" W !?4,*7,"No 'Start Date' on file...can't enter OP visit dates..." K X G DDAT4
 ;I $P(IB00,"^",2)']"" W !?4,*7,"No 'End Date' on file...can't enter OP visit dates..." K X G DDAT4
 ;I X<$P(IB00,"^",1) W !?4,*7,"Can't enter a visit date prior to 'Start Date'..." K X G DDAT4
 ;I X>$P(IB00,"^",2) W !?4,*7,"Can't enter a visit date later than 'End Date'..." K X G DDAT4
 ;I $P(^DGCR(399,IBIFN,0),"^",19)'=2,$D(^DGCR(399,"ASC2",IBIFN)),$O(^DGCR(399,IBIFN,"OP",0)) W !?4,*7,"Only 1 visit date allowed on bills with Amb. Surg. Codes!" K X G DDAT4
 ;D APPT^IBCU3,DUPCHK^IBCU3
 G DDAT4
 ;
DDAT3 ; - x-ref call for to and from dates, REPLACED BY TRIGGERS ON .08, 151, 152 ON 10/18/93
 ;if inpatient bill return DGNEWLOS to cause recalc of los in IBSC6
 G DDAT4:'$D(X)
 I $D(^DGCR(399,DA,0)),$P(^(0),"^",5)<3 S DGNEWLOS=1
 S IB00=$S($D(^DGCR(399,+DA,"U")):^("U"),1:"") I IB00']"" K X G DDAT4
 S IB02=$S(+$E(IB00,4,5)<10:$E(IB00,2,3),1:$E(IB00,2,3)+1),IB01=$E(IB00,1)_IB02_"0930",$P(^DGCR(399,DA,"U1"),"^",9)=IB02 ;,$P(^DGCR(399,DA,"U1"),"^",11)=$S($P(IB00,"^",2)>IB01:IB02+1,1:"")
 ;I $P(^DGCR(399,DA,"U1"),"^",11)="" S $P(^("U1"),"^",12)=""
 ;
DDAT4 K IB00,IB01,IB02,IB03,DGX,DGNOAP,DGJ,DGPROC,DGPRDT,DGPRDTE,DGPRDTB Q
 ;
OTDAT ; Input transform for Other Care Start Date (399,48,.02)
 I ('$G(DA(1)))!('$G(X)) Q
 N IBX S IBX=$G(^DGCR(399,DA(1),"U"))
 I +X<+IBX W !,?4,"Can Not Precede Bill Start Date!",!,*7 K X Q
 I +X>+$P(IBX,U,2) W !,?4,"Can not be after Bill End Date!",!,*7 K X Q
 Q
 ;
 ;
 ;
TO ;151 pseudo input x-form
 I +X_.9<IBIDS(.03) W !?4,"Cannot precede the 'EVENT DATE'!",*7 K X Q
 I +X>(DT_".2359") W !?4,"Cannot bill for future treatment!",*7 K X
 Q
FROM ;152 pseudo input x-form
 I '$D(IBIDS(151)) W !?4,"'Start Date' must be specified first!",*7 K X Q
 I +X<IBIDS(151) W !?4,"Cannot preceed the 'Start Date'!",*7 K X Q
 ;I $S($E(IBIDS(151),4,5)<10:$E(IBIDS(151),2,3),1:$E(IBIDS(151),2,3)+1)'=$S($E(X,4,5)<10:$E(X,2,3),1:$E(X,2,3)+1) K X W !?4,"Must be in same fiscal year!",*7 Q
 ;I $$FY(IBIDS(151))'=$$FY(X) K X W !?4,"Must be in same fiscal year!",*7 Q
 ;I $E(IBIDS(151),1,3)'=$E(X,1,3) K X W !?4,"Must be in same calendar year!",*7 Q
 Q
 ;
FY(DATE) ; return a dates Fiscal Year
 N IBYR,IBFY S IBFY=""
 I $G(DATE)?7N.E S IBYR=$S($E(DATE,4,5)<10:$E(DATE,1,3),1:$E(DATE,1,3)+1),IBFY=$E(IBYR,2,3)
 Q IBFY
 ;
SPEC ;  - calculate discharge specialty
 ;  - input  IBids(.08) = ptf record number
 ;  - output IBids(161) = pointer to billing specialty in 399.1
 K IBIDS(161)
 Q:$S('$D(IBIDS(.08)):1,'$D(^DGPT(+IBIDS(.08),70)):1,'$P(^(70),"^",2):1,'$D(^DIC(42.4,+$P(^(70),"^",2),0)):1,1:0)  S IBIDS(161)=$P(^DGPT(IBIDS(.08),70),"^",2)
 S IBIDS(161)=$P($G(^DIC(42.4,+IBIDS(161),0)),"^",5) I IBIDS(161)="" K IBIDS(161) Q
 S IBIDS(161)=$O(^DGCR(399.1,"B",IBIDS(161),0))
 I '$D(^DGCR(399.1,+IBIDS(161),0)) K IBIDS(161)
 Q
 ;
PROCDT ;  - find first and last dates of procedures
 ;    can't set from and to date inside of this range
 S (DGPRDT,DGPROC,DGPRDTE,DGPRDTB)=0
 F  S DGPROC=$O(^DGCR(399,+DA,"CP",DGPROC)) Q:'DGPROC  S DGPRDT=$P($G(^DGCR(399,+DA,"CP",DGPROC,0)),"^",2) D
 . I DGPRDTB=0!(DGPRDTB>DGPRDT) S DGPRDTB=DGPRDT
 . I DGPRDTE=0!(DGPRDTE<DGPRDT) S DGPRDTE=DGPRDT
 . Q
 Q
 ;
TOBIN(Y,DA) ; Screen for UB-04 bill classification based on UB-04 location of care
 ; Y = internal value of code for field .25 (UB-04 BILL CLASSIFICATION)
 ; DA = bill ien in file 399
 N IB0
 S IB0=$P($G(^DGCR(399,DA,0)),U,24) ; Get UB-04 LOCATION OF CARE value
 Q $S('IB0:0,(","_$P($G(^DGCR(399.1,+Y,0)),U,24)_",")'[(","_IB0_","):0,1:1)
 ;
TRIG05(X,D0) ; Trigger executed on field .05 of file 399 to set field .25
 ; Find the correct entry in file 399.1 that corresponds to the value in .05
 ; X = value of field .05, location of care
 ; D0 = IEN of bill entry in file 399
 N Z,Z0,IEN,LOC
 S LOC=$P($G(^DGCR(399,D0,0)),U,4)
 S IEN="",Z=0
 I LOC'="" F  S Z=$O(^DGCR(399.1,"C",X,Z)) Q:'Z  S Z0=$P($G(^DGCR(399.1,Z,0)),U,23,24) I +Z0,(","_$P(Z0,U,2)_",")[(","_LOC_",") S IEN=Z Q
 Q IEN
 ;
TOB(IBIFN,POS) ;Function returns the 3 digit type of bill from UB-04
 ;  fields or the position (1-3) as determined by POS (optional)
 N Z
 S Z=$P($G(^DGCR(399,IBIFN,0)),U,24,26),Z=$P(Z,U)_$P($G(^DGCR(399.1,+$P(Z,U,2),0)),U,2)_$P(Z,U,3)
 Q $S('$G(POS):Z,1:$E(Z,+POS))
 ;