IBCU4 ;ALB/AAS - BILLING UTILITY ROUTINE (CONTINUED) ;12-FEB-90
;;2.0;INTEGRATED BILLING;**109,122,137,245,349,371,399,461,532,718**;21-MAR-94;Build 73
;;Per VA Directive 6402, 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 precede the 'Start Date'!",*7 K X G DDAT4
I $P($G(^DGCR(399,+DA,0)),U,5)>2,$$ICD10S(+IB00,+X) W !?4,"Bill Statement dates cannot span ICD-10 activation 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)+1) W !,?4,"Cannot be after Bill End Date!",!,*7 K X Q
Q
;
CHDAT ; Input transform for chiropractic-related dates (399/245,246,247)
; Make sure that date entered is not after end date of the bill
Q:'$D(X)
N IBX,Y
S IBX=$P($G(^DGCR(399,+DA,"U")),U,2)
I IBX="" W !?4,*7,"No end date of the bill on file - can't enter chiropractic-related dates " K X Q
I X>+IBX S Y=IBX D DD^%DT W !,?4,*7,"This date cannot be after the end date of the claim ("_Y_") " 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 precede the 'Start Date'!",*7 K X Q
I IBIDS(.05)>2,$$ICD10S(+IBIDS(151),+X) W !?4,"Bill Statement dates cannot span ICD-10 activation 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
;
ICD10S(BDT,EDT,IBIFN) ; return Code Version Date if bill dates span the ICD-10 activation date
; enter either the bill to check or the dates to check
N IBS,IBV,IBU S IBS=""
S IBV=$$CSVDATE^IBACSV(30)
I +$G(IBIFN) S IBU=$G(^DGCR(399,+IBIFN,"U")) S:'$G(BDT) BDT=+IBU S:'$G(EDT) EDT=+$P(IBU,U,2)
I $G(BDT)<IBV,$G(EDT)'<IBV S IBS=IBV
Q IBS
;
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
; *532 return the last entry (eg. #4-lab)
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 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))
;
;I $$INDIVIDUAL^IBCU4(2122612,2,.DIC)
;SCREEN TO PREVENT BILLER CHOOSING A FACILITY TYPE PROVIDER FROM FILE #355.93 IB NON/OTHER VA BILLING PROVIDER
;WHEN CERTAIN CRITERIA ARE MET
;TPF;IB*2.0*718;EBILL-95;
INDIVIDUAL(IBIFN,PROVTYPE,PHYSFUNC) ;EP - ONLY INDIVIDUAL TYPE
;
;NEW SCREEN FOR FIELD #.02 'PERFORMED BY' IN SUBFILE #222 'PROVIDER' ON CLAIMS LEVEL
;
;S DIC(""S"")="I $$INDIVIDUAL^IBCU4($G(IBINP),$G(IBCUBFT),$P(^(0),U,2),$P($G(^DGCR(399,D0,""""PRV"""",D1,0)),U))"
;
;INPUT:
;
; IBIFN = #399 BILL/CLAIMS INTERNAL FILE NUMBER (IEN)
;
;
; PROVTYPE = INDIVIDUAL OR FACILITY FILE #355.93 FIELD #.02 PROVIDER TYPE
; FACILITY/GROUP = 1
; INDIVIDUAL = 2
;
; PHYSFUNC = RENDERING, OPERATING ETC CLAIM LEVEL 399.0222 PROVIDER FIELD #.01 FUNCTION
; '1' FOR REFERRING;
; '2' FOR OPERATING;
; '3' FOR RENDERING;
; '4' FOR ATTENDING;
; '5' FOR SUPERVISING;
; '9' FOR OTHER OPERATING;
; '6' FOR ASSISTANT SURGEON;
;
;REQUIRED VARIABLES FOR SCREEN:
;
; IBCUBFT = FORM TYPE CMS-1500 ETC FILE #399 FIELD #.19 FORM TYPE
; CMS-1500 = 2
; UB-04 = 3
; J430D = 7
;
;OUTPUT:
; GIVEN PROVIDER TYPE, FORM TYPE AND PHYSICIAN FUNCTION IS A FACILITY ALLOWED?
; 0 = NO
; 1 = YES
;
;
;WE ONLY NEED THIS IN THE INPUT TRANSFORM WHEN ADDING A PROVIDER VIA LAYGO
;WHEN THE USER ENTERS THE PROVIDER TYPE FIELD IN FILE #355.93
;TESTING CONFIRMS THESE ARRAYS ARE SET AND KILLED AS THE USER ENTERS AND EXITS EDITING
;PROVIDERS ON THE CLAIM AND LINE LEVELS.
;
Q:$G(XQY0)'[("IB EDIT BILLING INFO") 1 ;NO SCREEN FOR ANY OPTION EXCEPT BILLING EDIT
;
I $G(PROVTYPE)="" Q 0 ;ADDED FOR ENTRIES WITH NO PROVIDER TYPE. BAD ENTRY. ADD POST INSTALL TO LOOK FOR BAD DATA
;
I $D(IBLNPRV),'$G(PHYSFUNC) D
.S PHYSFUNC=$P($G(^DGCR(399,IBIFN,"CP",D1,"LNPRV",D2,0)),U)
;
I $D(IBPRV),'$G(PHYSFUNC) D
.S PHYSFUNC=$P($G(^DGCR(399,IBIFN,"PRV",D1,0)),U)
;
Q:'$G(IBIFN)!'$G(PHYSFUNC) 1 ;NEED BILL/CLAIMS IEN, PHYSICIAN FUNCTION AND PROVIDER TYPE TO PROPERLY SCREEN
;
N IBCUBFT
S:$G(IBCUBFT)="" IBCUBFT=$$FT^IBCEF(IBIFN) ;NEEDED FOR LINE LEVEL
Q:'$G(IBCUBFT) 1 ;NEED CLAIM TYPE
;
;ONLY NEED TO DO THE CONDITONAL IF THE PROVIDER TYPE CHOSEN IS FACILITY/GROUP. MORE EFFICIENT?
I PROVTYPE=1,((IBCUBFT=2)!(IBCUBFT=7)!(IBCUBFT=3)),(PHYSFUNC'=3) Q 0
E I PROVTYPE=1,(IBCUBFT=3),(PHYSFUNC=3) Q 0
Q 1
;
;D INDIVHELP^IBCU4
INDIVHELP ;EP - DISPLAY XECUTABLE HELP FOR NEW SCREEN IN 399.002 AND 399.0404
;
N FUNCDESC ;WCJ;IB718;SQA
Q:$G(XQY0)'[("IB EDIT BILLING INFO") 1 ;NO SCREEN FOR ANY OPTION EXCEPT BILLING EDIT
;
I $D(IBLNPRV) D
.S PHYSFUNC=$P($G(^DGCR(399,IBIFN,"CP",D1,"LNPRV",D2,0)),U)
E I $D(IBPRV) D
.S PHYSFUNC=$P($G(^DGCR(399,IBIFN,"PRV",D1,0)),U)
S FUNCDESC=$$PHYSFUNC^IBCU4(PHYSFUNC)
;
N MSG
S MSG(1)=" "
S MSG(1,"F")="!!"
S MSG(2)="You are entering a "_FUNCDESC_" provider."
S MSG(2,"F")="!!?10"
S MSG(3)="Only a RENDERING provider can have a NON-VA PROVIDER"
S MSG(3,"F")="!?10"
S MSG(4)="with a PROVIDER TYPE of FACILITY/GROUP"
S MSG(4,"F")="!?10"
S MSG(5)=" and only when it is a CMS-1500 or J430D form."
S MSG(5,"F")="!?10"
S MSG(6)=" "
S MSG(6,"F")="!!"
D EN^DDIOL(.MSG)
Q
;
;W $$PHYSFUNC^IBCU4(3)
PHYSFUNC(PHYSFUNC) ;EP -RETURN PHYSFUNC FOR SETCODE
N CHOICES,CODE,CODEPAIR,DESC,PIECE,SETCODES ;WCJ;IB718;SQA
S SETCODES=$P($G(^DD(399.0222,.01,0)),U,3)
F PIECE=1:1 S CODEPAIR=$P(SETCODES,";",PIECE) Q:CODEPAIR="" D
.S CODE=$P(CODEPAIR,":")
.S DESC=$P(CODEPAIR,":",2)
.S CHOICES(CODE)=DESC
I '$D(CHOICES(PHYSFUNC)) Q "UNKNOWN"
Q CHOICES(PHYSFUNC)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCU4 10824 printed Sep 23, 2025@19:56:54 Page 2
IBCU4 ;ALB/AAS - BILLING UTILITY ROUTINE (CONTINUED) ;12-FEB-90
+1 ;;2.0;INTEGRATED BILLING;**109,122,137,245,349,371,399,461,532,718**;21-MAR-94;Build 73
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;MAP TO DGCRU4
+5 ;
DDAT ;Input transform for Statement Covers From field
+1 IF '$DATA(DA)
GOTO TO
+2 SET IB00=+$PIECE(^DGCR(399,+DA,0),"^",3)
IF +X<$PIECE(IB00,".",1)
WRITE !?4,"Cannot precede the 'EVENT DATE'!",*7
KILL X
GOTO DDAT4
+3 IF +X>(DT_".2359")
WRITE !?4,"Cannot bill for future treatment!",*7
KILL X
GOTO DDAT4
+4 DO PROCDT
+5 IF DGPRDTB
IF X>DGPRDTB
KILL X
WRITE !?4,"Can't be greater than date of specified Procedures!",*7
GOTO DDAT4
+6 GOTO DDAT4
DDAT1 ;Input transform for Statement covers to
+1 IF '$DATA(DA)
GOTO FROM
+2 SET IB00=$SELECT($DATA(^DGCR(399,+DA,"U")):$PIECE(^("U"),"^",1),1:"")
IF 'IB00
WRITE !?4,"'Start Date' must be specified first!",*7
KILL X
GOTO DDAT4
+3 IF +X>DT
WRITE !?4,"Cannot bill for future treatment!",*7
KILL X
GOTO DDAT4
+4 IF +X<IB00
WRITE !?4,"Cannot precede the 'Start Date'!",*7
KILL X
GOTO DDAT4
+5 IF $PIECE($GET(^DGCR(399,+DA,0)),U,5)>2
IF $$ICD10S(+IB00,+X)
WRITE !?4,"Bill Statement dates cannot span ICD-10 activation date!",*7
KILL X
GOTO DDAT4
+6 ;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
+7 ;I $$FY(+IB00)'=$$FY(X) K X W !?4,"Must be in same fiscal year!",*7 G DDAT4
+8 ;I $E(IB00,1,3)'=$E(X,1,3) K X W !?4,"Must be in same calendar year!",*7 G DDAT4
+9 DO PROCDT
+10 IF DGPRDTE
IF X<DGPRDTE
KILL X
WRITE !?4,"Can't be less than date of specified Procedures!",*7
GOTO DDAT4
+11 GOTO DDAT4
+12 ;
+13 ;DDAT2 ;Input transform for OP VISITS DATE(S) field REPLACED WITH IBCU41 6/15/93
+14 ;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
+15 ;I $P(IB00,"^",2)']"" W !?4,*7,"No 'End Date' on file...can't enter OP visit dates..." K X G DDAT4
+16 ;I X<$P(IB00,"^",1) W !?4,*7,"Can't enter a visit date prior to 'Start Date'..." K X G DDAT4
+17 ;I X>$P(IB00,"^",2) W !?4,*7,"Can't enter a visit date later than 'End Date'..." K X G DDAT4
+18 ;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
+19 ;D APPT^IBCU3,DUPCHK^IBCU3
+20 GOTO DDAT4
+21 ;
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
+2 if '$DATA(X)
GOTO DDAT4
+3 IF $DATA(^DGCR(399,DA,0))
IF $PIECE(^(0),"^",5)<3
SET DGNEWLOS=1
+4 SET IB00=$SELECT($DATA(^DGCR(399,+DA,"U")):^("U"),1:"")
IF IB00']""
KILL X
GOTO DDAT4
+5 ;,$P(^DGCR(399,DA,"U1"),"^",11)=$S($P(IB00,"^",2)>IB01:IB02+1,1:"")
SET IB02=$SELECT(+$EXTRACT(IB00,4,5)<10:$EXTRACT(IB00,2,3),1:$EXTRACT(IB00,2,3)+1)
SET IB01=$EXTRACT(IB00,1)_IB02_"0930"
SET $PIECE(^DGCR(399,DA,"U1"),"^",9)=IB02
+6 ;I $P(^DGCR(399,DA,"U1"),"^",11)="" S $P(^("U1"),"^",12)=""
+7 ;
DDAT4 KILL IB00,IB01,IB02,IB03,DGX,DGNOAP,DGJ,DGPROC,DGPRDT,DGPRDTE,DGPRDTB
QUIT
+1 ;
OTDAT ; Input transform for Other Care Start Date (399,48,.02)
+1 IF ('$GET(DA(1)))!('$GET(X))
QUIT
+2 NEW IBX
SET IBX=$GET(^DGCR(399,DA(1),"U"))
+3 IF +X<+IBX
WRITE !,?4,"Can Not Precede Bill Start Date!",!,*7
KILL X
QUIT
+4 IF +X>(+$PIECE(IBX,U,2)+1)
WRITE !,?4,"Cannot be after Bill End Date!",!,*7
KILL X
QUIT
+5 QUIT
+6 ;
CHDAT ; Input transform for chiropractic-related dates (399/245,246,247)
+1 ; Make sure that date entered is not after end date of the bill
+2 if '$DATA(X)
QUIT
+3 NEW IBX,Y
+4 SET IBX=$PIECE($GET(^DGCR(399,+DA,"U")),U,2)
+5 IF IBX=""
WRITE !?4,*7,"No end date of the bill on file - can't enter chiropractic-related dates "
KILL X
QUIT
+6 IF X>+IBX
SET Y=IBX
DO DD^%DT
WRITE !,?4,*7,"This date cannot be after the end date of the claim ("_Y_") "
KILL X
QUIT
+7 QUIT
+8 ;
TO ;151 pseudo input x-form
+1 IF +X_.9<IBIDS(.03)
WRITE !?4,"Cannot precede the 'EVENT DATE'!",*7
KILL X
QUIT
+2 IF +X>(DT_".2359")
WRITE !?4,"Cannot bill for future treatment!",*7
KILL X
+3 QUIT
FROM ;152 pseudo input x-form
+1 IF '$DATA(IBIDS(151))
WRITE !?4,"'Start Date' must be specified first!",*7
KILL X
QUIT
+2 IF +X<IBIDS(151)
WRITE !?4,"Cannot precede the 'Start Date'!",*7
KILL X
QUIT
+3 IF IBIDS(.05)>2
IF $$ICD10S(+IBIDS(151),+X)
WRITE !?4,"Bill Statement dates cannot span ICD-10 activation date!",*7
KILL X
QUIT
+4 ;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
+5 ;I $$FY(IBIDS(151))'=$$FY(X) K X W !?4,"Must be in same fiscal year!",*7 Q
+6 ;I $E(IBIDS(151),1,3)'=$E(X,1,3) K X W !?4,"Must be in same calendar year!",*7 Q
+7 QUIT
+8 ;
FY(DATE) ; return a dates Fiscal Year
+1 NEW IBYR,IBFY
SET IBFY=""
+2 IF $GET(DATE)?7N.E
SET IBYR=$SELECT($EXTRACT(DATE,4,5)<10:$EXTRACT(DATE,1,3),1:$EXTRACT(DATE,1,3)+1)
SET IBFY=$EXTRACT(IBYR,2,3)
+3 QUIT IBFY
+4 ;
SPEC ; - calculate discharge specialty
+1 ; - input IBids(.08) = ptf record number
+2 ; - output IBids(161) = pointer to billing specialty in 399.1
+3 KILL IBIDS(161)
+4 if $SELECT('$DATA(IBIDS(.08))
QUIT
SET IBIDS(161)=$PIECE(^DGPT(IBIDS(.08),70),"^",2)
+5 SET IBIDS(161)=$PIECE($GET(^DIC(42.4,+IBIDS(161),0)),"^",5)
IF IBIDS(161)=""
KILL IBIDS(161)
QUIT
+6 SET IBIDS(161)=$ORDER(^DGCR(399.1,"B",IBIDS(161),0))
+7 IF '$DATA(^DGCR(399.1,+IBIDS(161),0))
KILL IBIDS(161)
+8 QUIT
+9 ;
PROCDT ; - find first and last dates of procedures
+1 ; can't set from and to date inside of this range
+2 SET (DGPRDT,DGPROC,DGPRDTE,DGPRDTB)=0
+3 FOR
SET DGPROC=$ORDER(^DGCR(399,+DA,"CP",DGPROC))
if 'DGPROC
QUIT
SET DGPRDT=$PIECE($GET(^DGCR(399,+DA,"CP",DGPROC,0)),"^",2)
Begin DoDot:1
+4 IF DGPRDTB=0!(DGPRDTB>DGPRDT)
SET DGPRDTB=DGPRDT
+5 IF DGPRDTE=0!(DGPRDTE<DGPRDT)
SET DGPRDTE=DGPRDT
+6 QUIT
End DoDot:1
+7 QUIT
+8 ;
ICD10S(BDT,EDT,IBIFN) ; return Code Version Date if bill dates span the ICD-10 activation date
+1 ; enter either the bill to check or the dates to check
+2 NEW IBS,IBV,IBU
SET IBS=""
+3 SET IBV=$$CSVDATE^IBACSV(30)
+4 IF +$GET(IBIFN)
SET IBU=$GET(^DGCR(399,+IBIFN,"U"))
if '$GET(BDT)
SET BDT=+IBU
if '$GET(EDT)
SET EDT=+$PIECE(IBU,U,2)
+5 IF $GET(BDT)<IBV
IF $GET(EDT)'<IBV
SET IBS=IBV
+6 QUIT IBS
+7 ;
TOBIN(Y,DA) ; Screen for UB-04 bill classification based on UB-04 location of care
+1 ; Y = internal value of code for field .25 (UB-04 BILL CLASSIFICATION)
+2 ; DA = bill ien in file 399
+3 NEW IB0
+4 ; Get UB-04 LOCATION OF CARE value
SET IB0=$PIECE($GET(^DGCR(399,DA,0)),U,24)
+5 QUIT $SELECT('IB0:0,(","_$PIECE($GET(^DGCR(399.1,+Y,0)),U,24)_",")'[(","_IB0_","):0,1:1)
+6 ;
TRIG05(X,D0) ; Trigger executed on field .05 of file 399 to set field .25
+1 ; Find the correct entry in file 399.1 that corresponds to the value in .05
+2 ; X = value of field .05, location of care
+3 ; D0 = IEN of bill entry in file 399
+4 NEW Z,Z0,IEN,LOC
+5 SET LOC=$PIECE($GET(^DGCR(399,D0,0)),U,4)
+6 SET IEN=""
SET Z=0
+7 ; *532 return the last entry (eg. #4-lab)
+8 IF LOC'=""
FOR
SET Z=$ORDER(^DGCR(399.1,"C",X,Z))
if 'Z
QUIT
SET Z0=$PIECE($GET(^DGCR(399.1,Z,0)),U,23,24)
IF +Z0
IF (","_$PIECE(Z0,U,2)_",")[(","_LOC_",")
SET IEN=Z
+9 QUIT IEN
+10 ;
TOB(IBIFN,POS) ;Function returns the 3 digit type of bill from UB-04
+1 ; fields or the position (1-3) as determined by POS (optional)
+2 NEW Z
+3 SET Z=$PIECE($GET(^DGCR(399,IBIFN,0)),U,24,26)
SET Z=$PIECE(Z,U)_$PIECE($GET(^DGCR(399.1,+$PIECE(Z,U,2),0)),U,2)_$PIECE(Z,U,3)
+4 QUIT $SELECT('$GET(POS):Z,1:$EXTRACT(Z,+POS))
+5 ;
+6 ;I $$INDIVIDUAL^IBCU4(2122612,2,.DIC)
+7 ;SCREEN TO PREVENT BILLER CHOOSING A FACILITY TYPE PROVIDER FROM FILE #355.93 IB NON/OTHER VA BILLING PROVIDER
+8 ;WHEN CERTAIN CRITERIA ARE MET
+9 ;TPF;IB*2.0*718;EBILL-95;
INDIVIDUAL(IBIFN,PROVTYPE,PHYSFUNC) ;EP - ONLY INDIVIDUAL TYPE
+1 ;
+2 ;NEW SCREEN FOR FIELD #.02 'PERFORMED BY' IN SUBFILE #222 'PROVIDER' ON CLAIMS LEVEL
+3 ;
+4 ;S DIC(""S"")="I $$INDIVIDUAL^IBCU4($G(IBINP),$G(IBCUBFT),$P(^(0),U,2),$P($G(^DGCR(399,D0,""""PRV"""",D1,0)),U))"
+5 ;
+6 ;INPUT:
+7 ;
+8 ; IBIFN = #399 BILL/CLAIMS INTERNAL FILE NUMBER (IEN)
+9 ;
+10 ;
+11 ; PROVTYPE = INDIVIDUAL OR FACILITY FILE #355.93 FIELD #.02 PROVIDER TYPE
+12 ; FACILITY/GROUP = 1
+13 ; INDIVIDUAL = 2
+14 ;
+15 ; PHYSFUNC = RENDERING, OPERATING ETC CLAIM LEVEL 399.0222 PROVIDER FIELD #.01 FUNCTION
+16 ; '1' FOR REFERRING;
+17 ; '2' FOR OPERATING;
+18 ; '3' FOR RENDERING;
+19 ; '4' FOR ATTENDING;
+20 ; '5' FOR SUPERVISING;
+21 ; '9' FOR OTHER OPERATING;
+22 ; '6' FOR ASSISTANT SURGEON;
+23 ;
+24 ;REQUIRED VARIABLES FOR SCREEN:
+25 ;
+26 ; IBCUBFT = FORM TYPE CMS-1500 ETC FILE #399 FIELD #.19 FORM TYPE
+27 ; CMS-1500 = 2
+28 ; UB-04 = 3
+29 ; J430D = 7
+30 ;
+31 ;OUTPUT:
+32 ; GIVEN PROVIDER TYPE, FORM TYPE AND PHYSICIAN FUNCTION IS A FACILITY ALLOWED?
+33 ; 0 = NO
+34 ; 1 = YES
+35 ;
+36 ;
+37 ;WE ONLY NEED THIS IN THE INPUT TRANSFORM WHEN ADDING A PROVIDER VIA LAYGO
+38 ;WHEN THE USER ENTERS THE PROVIDER TYPE FIELD IN FILE #355.93
+39 ;TESTING CONFIRMS THESE ARRAYS ARE SET AND KILLED AS THE USER ENTERS AND EXITS EDITING
+40 ;PROVIDERS ON THE CLAIM AND LINE LEVELS.
+41 ;
+42 ;NO SCREEN FOR ANY OPTION EXCEPT BILLING EDIT
if $GET(XQY0)'[("IB EDIT BILLING INFO")
QUIT 1
+43 ;
+44 ;ADDED FOR ENTRIES WITH NO PROVIDER TYPE. BAD ENTRY. ADD POST INSTALL TO LOOK FOR BAD DATA
IF $GET(PROVTYPE)=""
QUIT 0
+45 ;
+46 IF $DATA(IBLNPRV)
IF '$GET(PHYSFUNC)
Begin DoDot:1
+47 SET PHYSFUNC=$PIECE($GET(^DGCR(399,IBIFN,"CP",D1,"LNPRV",D2,0)),U)
End DoDot:1
+48 ;
+49 IF $DATA(IBPRV)
IF '$GET(PHYSFUNC)
Begin DoDot:1
+50 SET PHYSFUNC=$PIECE($GET(^DGCR(399,IBIFN,"PRV",D1,0)),U)
End DoDot:1
+51 ;
+52 ;NEED BILL/CLAIMS IEN, PHYSICIAN FUNCTION AND PROVIDER TYPE TO PROPERLY SCREEN
if '$GET(IBIFN)!'$GET(PHYSFUNC)
QUIT 1
+53 ;
+54 NEW IBCUBFT
+55 ;NEEDED FOR LINE LEVEL
if $GET(IBCUBFT)=""
SET IBCUBFT=$$FT^IBCEF(IBIFN)
+56 ;NEED CLAIM TYPE
if '$GET(IBCUBFT)
QUIT 1
+57 ;
+58 ;ONLY NEED TO DO THE CONDITONAL IF THE PROVIDER TYPE CHOSEN IS FACILITY/GROUP. MORE EFFICIENT?
+59 IF PROVTYPE=1
IF ((IBCUBFT=2)!(IBCUBFT=7)!(IBCUBFT=3))
IF (PHYSFUNC'=3)
QUIT 0
+60 IF '$TEST
IF PROVTYPE=1
IF (IBCUBFT=3)
IF (PHYSFUNC=3)
QUIT 0
+61 QUIT 1
+62 ;
+63 ;D INDIVHELP^IBCU4
INDIVHELP ;EP - DISPLAY XECUTABLE HELP FOR NEW SCREEN IN 399.002 AND 399.0404
+1 ;
+2 ;WCJ;IB718;SQA
NEW FUNCDESC
+3 ;NO SCREEN FOR ANY OPTION EXCEPT BILLING EDIT
if $GET(XQY0)'[("IB EDIT BILLING INFO")
QUIT 1
+4 ;
+5 IF $DATA(IBLNPRV)
Begin DoDot:1
+6 SET PHYSFUNC=$PIECE($GET(^DGCR(399,IBIFN,"CP",D1,"LNPRV",D2,0)),U)
End DoDot:1
+7 IF '$TEST
IF $DATA(IBPRV)
Begin DoDot:1
+8 SET PHYSFUNC=$PIECE($GET(^DGCR(399,IBIFN,"PRV",D1,0)),U)
End DoDot:1
+9 SET FUNCDESC=$$PHYSFUNC^IBCU4(PHYSFUNC)
+10 ;
+11 NEW MSG
+12 SET MSG(1)=" "
+13 SET MSG(1,"F")="!!"
+14 SET MSG(2)="You are entering a "_FUNCDESC_" provider."
+15 SET MSG(2,"F")="!!?10"
+16 SET MSG(3)="Only a RENDERING provider can have a NON-VA PROVIDER"
+17 SET MSG(3,"F")="!?10"
+18 SET MSG(4)="with a PROVIDER TYPE of FACILITY/GROUP"
+19 SET MSG(4,"F")="!?10"
+20 SET MSG(5)=" and only when it is a CMS-1500 or J430D form."
+21 SET MSG(5,"F")="!?10"
+22 SET MSG(6)=" "
+23 SET MSG(6,"F")="!!"
+24 DO EN^DDIOL(.MSG)
+25 QUIT
+26 ;
+27 ;W $$PHYSFUNC^IBCU4(3)
PHYSFUNC(PHYSFUNC) ;EP -RETURN PHYSFUNC FOR SETCODE
+1 ;WCJ;IB718;SQA
NEW CHOICES,CODE,CODEPAIR,DESC,PIECE,SETCODES
+2 SET SETCODES=$PIECE($GET(^DD(399.0222,.01,0)),U,3)
+3 FOR PIECE=1:1
SET CODEPAIR=$PIECE(SETCODES,";",PIECE)
if CODEPAIR=""
QUIT
Begin DoDot:1
+4 SET CODE=$PIECE(CODEPAIR,":")
+5 SET DESC=$PIECE(CODEPAIR,":",2)
+6 SET CHOICES(CODE)=DESC
End DoDot:1
+7 IF '$DATA(CHOICES(PHYSFUNC))
QUIT "UNKNOWN"
+8 QUIT CHOICES(PHYSFUNC)
