Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBCU4

IBCU4.m

Go to the documentation of this file. 
  1. IBCU4	;ALB/AAS - BILLING UTILITY ROUTINE (CONTINUED)  ;12-FEB-90
  1. 	;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
  1. 	;;Per VHA Directive 10-93-142, this routine should not be modified.
  1. 	;
  1. 	;MAP TO DGCRU4
  1. 	;
  1. DDAT	;Input transform for Statement Covers From field
  1. 	I '$D(DA) G TO
  1. 	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
  1. 	I +X>(DT_".2359") W !?4,"Cannot bill for future treatment!",*7 K X G DDAT4
  1. 	D PROCDT
  1. 	I DGPRDTB,X>DGPRDTB K X W !?4,"Can't be greater than date of specified Procedures!",*7 G DDAT4
  1. 	G DDAT4
  1. DDAT1	;Input transform for Satement covers to
  1. 	I '$D(DA) G FROM
  1. 	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
  1. 	I +X<IB00 W !?4,"Cannot preceed the 'Start Date'!",*7 K X G DDAT4
  1. 	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
  1. 	I $E(IB00,1,3)'=$E(X,1,3) K X W !?4,"Must be in same calendar year!",*7 G DDAT4
  1. 	D PROCDT
  1. 	I DGPRDTE,X<DGPRDTE K X W !?4,"Can't be less than date of specified Procedures!",*7 G DDAT4
  1. 	G DDAT4
  1. 	;
  1. 	;DDAT2   ;Input transform for OP VISITS DATE(S) field  REPLACED WITH IBCU41 6/15/93
  1. 	;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
  1. 	;I $P(IB00,"^",2)']"" W !?4,*7,"No 'End Date' on file...can't enter OP visit dates..." K X G DDAT4
  1. 	;I X<$P(IB00,"^",1) W !?4,*7,"Can't enter a visit date prior to 'Start Date'..." K X G DDAT4
  1. 	;I X>$P(IB00,"^",2) W !?4,*7,"Can't enter a visit date later than 'End Date'..." K X G DDAT4
  1. 	;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
  1. 	;D APPT^IBCU3,DUPCHK^IBCU3
  1. 	G DDAT4
  1. 	;
  1. DDAT3	; - x-ref call for to and from dates, REPLACED BY TRIGGERS ON .08, 151, 152 ON 10/18/93
  1. 	;if inpatient bill return DGNEWLOS to cause recalc of los in IBSC6
  1. 	G DDAT4:'$D(X)
  1. 	I $D(^DGCR(399,DA,0)),$P(^(0),"^",5)<3 S DGNEWLOS=1
  1. 	S IB00=$S($D(^DGCR(399,+DA,"U")):^("U"),1:"") I IB00']"" K X G DDAT4
  1. 	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:"")
  1. 	;I $P(^DGCR(399,DA,"U1"),"^",11)="" S $P(^("U1"),"^",12)=""
  1. 	;
  1. DDAT4	K IB00,IB01,IB02,IB03,DGX,DGNOAP,DGJ,DGPROC,DGPRDT,DGPRDTE,DGPRDTB Q
  1. 	;
  1. 	;
  1. TO	;151 pseudo input x-form
  1. 	I +X_.9<IBIDS(.03) W !?4,"Cannot precede the 'EVENT DATE'!",*7 K X Q
  1. 	I +X>(DT_".2359") W !?4,"Cannot bill for future treatment!",*7 K X
  1. 	Q
  1. FROM	;152 pseudo input x-form
  1. 	I '$D(IBIDS(151)) W !?4,"'Start Date' must be specified first!",*7 K X Q
  1. 	I +X<IBIDS(151) W !?4,"Cannot preceed the 'Start Date'!",*7 K X Q
  1. 	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
  1. 	I $E(IBIDS(151),1,3)'=$E(X,1,3) K X W !?4,"Must be in same calendar year!",*7 Q
  1. 	Q
  1. 	;
  1. SPEC	;  - calculate discharge specialty
  1. 	;  - input  IBids(.08) = ptf record number
  1. 	;  - output IBids(161) = pointer to billing specialty in 399.1
  1. 	K IBIDS(161)
  1. 	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)
  1. 	S IBIDS(161)=$P($G(^DIC(42.4,+IBIDS(161),0)),"^",5) I IBIDS(161)="" K IBIDS(161) Q
  1. 	S IBIDS(161)=$O(^DGCR(399.1,"B",IBIDS(161),0))
  1. 	I '$D(^DGCR(399.1,+IBIDS(161),0)) K IBIDS(161)
  1. 	Q
  1. 	;
  1. PROCDT	;  - find first and last dates of procedures
  1. 	;    can't set from and to date inside of this range
  1. 	S (DGPRDT,DGPROC,DGPRDTE,DGPRDTB)=0
  1. 	F  S DGPROC=$O(^DGCR(399,+DA,"CP",DGPROC)) Q:'DGPROC  S DGPRDT=$P($G(^DGCR(399,+DA,"CP",DGPROC,0)),"^",2) D
  1. 	. I DGPRDTB=0!(DGPRDTB>DGPRDT) S DGPRDTB=DGPRDT
  1. 	. I DGPRDTE=0!(DGPRDTE<DGPRDT) S DGPRDTE=DGPRDT
  1. 	. Q
  1. 	Q