IBCRHU1 ;ALB/ARH - RATES: UPLOAD UTILITIES ;22-MAY-1996
;;2.0;INTEGRATED BILLING;**52,106,138,245,427,634,667**;21-MAR-94;Build 65
;;Per VA Directive 6402, this routine should not be modified.
;
;
GETXTMP(IBXRF,ARR,ARR1,CS) ; get list of available files
; Output: ARR(file) = upload file description ^ total cnt
; ARR(file,subfile) = I ^ count ^ billable item type ^ charge set
; ARR1(I) = file ^ subfile
;
N IBX,IBY,IBL,CNT,IBLN,IBLN1 K ARR,ARR1 S (CNT,ARR,ARR1)=0 I $G(IBXRF)="" S IBXRF="IBCR UPLOAD"
S IBL=$L(IBXRF),IBY=$E(IBXRF,IBL),IBY=$A(IBY)-1,IBY=$C(IBY),IBX=$E(IBXRF,1,(IBL-1))_IBY_"~"
F S IBX=$O(^XTMP(IBX)) Q:IBX=""!(IBX'[IBXRF) I IBX[IBXRF D
. S IBLN=$G(^XTMP(IBX,0)) Q:IBLN=""
. S IBY=0 F S IBY=$O(^XTMP(IBX,IBY)) Q:IBY="" D
.. S IBLN1=$G(^XTMP(IBX,IBY)) Q:IBLN1="" I +$G(CS),'$P(IBLN1,U,3) Q
.. S CNT=CNT+1,(ARR,ARR1)=CNT,ARR1(CNT)=IBX_U_IBY
.. S ARR(IBX)=$P(IBLN,U,3,4),ARR(IBX,IBY)=CNT_U_IBLN1
Q
;
DISP(ARR) ; display list of available files by number
;
N IBX,IBY,IBLN,IBFCNT S IBFCNT=0
S IBX="" F S IBX=$O(ARR(IBX)) Q:IBX="" D
. S IBLN=ARR(IBX),IBFCNT=IBFCNT+1
. W !!,?5,IBX,?55,"Count = ",$P(IBLN,U,2)
. W !,?5,$P(IBLN,U,1)
. W !!,?6,"Subfile",?30,"Item",?39,"Count",?49,"Charge Set",!,?6,"-------",?30,"----",?39,"-----",?49,"-------------------------"
. S IBY="" F S IBY=$O(ARR(IBX,IBY)) Q:IBY="" D
.. S IBLN=ARR(IBX,IBY)
.. W !,?2,+IBLN,?6,IBY,?30,$E($$EXPAND^IBCRU1(363.3,.04,$P(IBLN,U,3)),1,5),?39,$P(IBLN,U,2),?49,$E($P($G(^IBE(363.1,+$P(IBLN,U,4),0)),U,1),1,30)
W !
Q
;
DISP1(IBXRF,ARR,ARR1,CS) ; get and display uploaded files
D GETXTMP($G(IBXRF),.ARR,.ARR1,$G(CS))
D DISP(.ARR)
Q
;
CHKDUP(CS,IBLN,ADD) ; check that item would not be a duplicate
; check on same charge but different date removed so each version is complete even if the charge does not change
N IBX,IBBI,IBITEM,IBARR S IBX=0
S IBBI=$$CSBI^IBCRU3($G(CS)) I 'IBBI S IBX="3^Subfile/Set Error: No Billable Item for the Charge Set" G CHKDUPQ
S IBITEM=+$$ITPTR^IBCRU2(+IBBI,$P($G(IBLN),U,1))
I 'IBITEM,+IBBI=3,'$G(ADD) S IBX=0 G CHKDUPQ ; new NDC numbers
I 'IBITEM S IBX="2^Line/Data Error: Item not found in source file" G CHKDUPQ
I $$FINDCI^IBCRU4(CS,IBITEM,$P(IBLN,U,2),$P(IBLN,U,5),$S($$RVCD(CS,IBITEM):124,1:""),$J($P(IBLN,U,4),"",2),,,$P(IBLN,U,6)) S IBX="2^Line/Data Error: Duplicate found, the same charge already exists for this item and effective date" G CHKDUPQ
I $$FINDCI^IBCRU4(CS,IBITEM,$P(IBLN,U,2),$P(IBLN,U,5)) S IBX="1^Line/Data Warning: Potential duplicate, a charge already exists for this item and effective date" G CHKDUPQ
;I '$P(IBLN,U,3) D ITMCHG^IBCRCC(CS,IBITEM,$P(IBLN,U,2),$P(IBLN,U,5),.IBARR) I +IBARR=1,+$P(IBARR,U,2)=+$P(IBLN,U,4) S IBX="2^Line/Data Error: Charge for item is not modified by the new entry" G CHKDUPQ
CHKDUPQ Q IBX
;
CHKLN(BI,IBLN) ; check if data in line item is valid Billable Item
; Input: IBLN= item ^ eff dt ^ inact dt ^ charge ^ cpt modifier
; Output: if data not good: x ^ error description
; w/ x=1 - line/data warning - bad data but field not required
; x=2 - line/data error - bad required data, item can not be loaded into CM
; x=3 - subfile/set error stop all processing
; do not have to check if NDC is in source, since it is added if not there
; check on cpt-modifier pair removed with RC v2.0, charge pairings do not match official pairings
N IBX,IBCSBR,IBITEM S IBX=0
I +$G(BI)'=3 S IBITEM=+$$ITPTR^IBCRU2(+$G(BI),$P($G(IBLN),U,1)) I 'IBITEM S IBX="2^Line/Data Error: Item not found in source file" G CHKLNQ
I +$G(BI)'=3,'$$ITFILE^IBCRU2(+$G(BI),IBITEM,$P(IBLN,U,2)) S IBX="2^Line/Data Error: Not a valid active Item in source file" G CHKLNQ
I +$G(BI)=2,+$P(IBLN,U,5),'$P($$MOD^ICPTMOD(+$P(IBLN,U,5),"I",+$P(IBLN,U,2)),U,7) S IBX="2^Line/Data Error: Not a valid active Modifier" G CHKLNQ
;I +$G(BI)=2,+$P(IBLN,U,5),+$$MODP^ICPTMOD(+IBITEM,+$P(IBLN,U,5),"I",$P(IBLN,U,2))<1 S IBX="2^Line/Data Error: Modifier "_$P($$MOD^ICPTMOD(+$P(IBLN,U,5),"I"),U,2)_" can not be used with CPT "_$P(IBLN,U,1) G CHKLNQ
I '$$VDATE($P(IBLN,U,2)) S IBX="2^Line/Data Error: Invalid Effective Date" G CHKLNQ
I $P(IBLN,U,3),'$$VDATE($P(IBLN,U,3)) S IBX="1^Line/Data Warning: Invalid Inactive Date" G CHKLNQ
CHKLNQ Q IBX
;
CHKFL(CS,FILE,IBSUBFL) ; Check the Charge Set and Host file are defined and match ok
; Output: if check is ok: 0
; if data not good: x ^ error description
; w/ x=3 - subfile/set error stop all processing
N IBX,IBY,IBCSBI S IBX=0
I '$G(CS) S IBX="3^Subfile/Set Error: No Charge Set Defined" G CHKFLQ
S IBCSBI=$$CSBI^IBCRU3(CS) I 'IBCSBI S IBX="3^Subfile/Set Error: No Billable Item for the Charge Set" G CHKFLQ
;
I $G(FILE)="" S IBX="3^Subfile/Set Error: Invalid Host File Name" G CHKFLQ
S IBY=$G(^XTMP(FILE,0)) I IBY="" S IBX="3^Subfile/Set Error: Host File Name Not Defined" G CHKFLQ
;
I $G(IBSUBFL)="" S IBX="3^Subfile/Set Error: Invalid Sub-File Name" G CHKFLQ
S IBY=$G(^XTMP(FILE,IBSUBFL)) I IBY="" S IBX="3^Subfile/Set Error: File Subset Not Defined" G CHKFLQ
I +IBCSBI'=+$P(IBY,U,2) S IBX="3^Subfile/Set Error: Charge Set rate Billable Item ("_$P(IBCSBI,U,2)_") does not match Host file Item ("_$$EXPAND^IBCRU1(363.3,.04,+$P(IBY,U,2))_")" G CHKFLQ
CHKFLQ Q IBX
;
RVCD(CS,IBITEM) ; *634 - assign Revenue Code #124 to 5 ms-drg charges
; Input: charge set, charge item
; Output: 0 or 1
N IBMHDG,IBCS0 S IBMHDG=0
S IBCS0=$G(^IBE(363.1,+$G(CS),0)) G:IBCS0="" RVCDQ
S IBCS0=$P(IBCS0,U,1)
I ($P(IBCS0," ",1,2)'="RC-INPT R&B")!($L(IBCS0," ")'=3) G RVCDQ
I $F("^881^882^883^885^886^",(U_IBITEM_U)) S IBMHDG=1
RVCDQ Q IBMHDG
;
VDATE(X) ; check for valid date, *667 check for valid year
N Y S Y=0 I +$G(X)?7N,X>2801010,X<3491232 S Y=1
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCRHU1 5937 printed Dec 13, 2024@02:19:37 Page 2
IBCRHU1 ;ALB/ARH - RATES: UPLOAD UTILITIES ;22-MAY-1996
+1 ;;2.0;INTEGRATED BILLING;**52,106,138,245,427,634,667**;21-MAR-94;Build 65
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;
GETXTMP(IBXRF,ARR,ARR1,CS) ; get list of available files
+1 ; Output: ARR(file) = upload file description ^ total cnt
+2 ; ARR(file,subfile) = I ^ count ^ billable item type ^ charge set
+3 ; ARR1(I) = file ^ subfile
+4 ;
+5 NEW IBX,IBY,IBL,CNT,IBLN,IBLN1
KILL ARR,ARR1
SET (CNT,ARR,ARR1)=0
IF $GET(IBXRF)=""
SET IBXRF="IBCR UPLOAD"
+6 SET IBL=$LENGTH(IBXRF)
SET IBY=$EXTRACT(IBXRF,IBL)
SET IBY=$ASCII(IBY)-1
SET IBY=$CHAR(IBY)
SET IBX=$EXTRACT(IBXRF,1,(IBL-1))_IBY_"~"
+7 FOR
SET IBX=$ORDER(^XTMP(IBX))
if IBX=""!(IBX'[IBXRF)
QUIT
IF IBX[IBXRF
Begin DoDot:1
+8 SET IBLN=$GET(^XTMP(IBX,0))
if IBLN=""
QUIT
+9 SET IBY=0
FOR
SET IBY=$ORDER(^XTMP(IBX,IBY))
if IBY=""
QUIT
Begin DoDot:2
+10 SET IBLN1=$GET(^XTMP(IBX,IBY))
if IBLN1=""
QUIT
IF +$GET(CS)
IF '$PIECE(IBLN1,U,3)
QUIT
+11 SET CNT=CNT+1
SET (ARR,ARR1)=CNT
SET ARR1(CNT)=IBX_U_IBY
+12 SET ARR(IBX)=$PIECE(IBLN,U,3,4)
SET ARR(IBX,IBY)=CNT_U_IBLN1
End DoDot:2
End DoDot:1
+13 QUIT
+14 ;
DISP(ARR) ; display list of available files by number
+1 ;
+2 NEW IBX,IBY,IBLN,IBFCNT
SET IBFCNT=0
+3 SET IBX=""
FOR
SET IBX=$ORDER(ARR(IBX))
if IBX=""
QUIT
Begin DoDot:1
+4 SET IBLN=ARR(IBX)
SET IBFCNT=IBFCNT+1
+5 WRITE !!,?5,IBX,?55,"Count = ",$PIECE(IBLN,U,2)
+6 WRITE !,?5,$PIECE(IBLN,U,1)
+7 WRITE !!,?6,"Subfile",?30,"Item",?39,"Count",?49,"Charge Set",!,?6,"-------",?30,"----",?39,"-----",?49,"-------------------------"
+8 SET IBY=""
FOR
SET IBY=$ORDER(ARR(IBX,IBY))
if IBY=""
QUIT
Begin DoDot:2
+9 SET IBLN=ARR(IBX,IBY)
+10 WRITE !,?2,+IBLN,?6,IBY,?30,$EXTRACT($$EXPAND^IBCRU1(363.3,.04,$PIECE(IBLN,U,3)),1,5),?39,$PIECE(IBLN,U,2),?49,$EXTRACT($PIECE($GET(^IBE(363.1,+$PIECE(IBLN,U,4),0)),U,1),1,30)
End DoDot:2
End DoDot:1
+11 WRITE !
+12 QUIT
+13 ;
DISP1(IBXRF,ARR,ARR1,CS) ; get and display uploaded files
+1 DO GETXTMP($GET(IBXRF),.ARR,.ARR1,$GET(CS))
+2 DO DISP(.ARR)
+3 QUIT
+4 ;
CHKDUP(CS,IBLN,ADD) ; check that item would not be a duplicate
+1 ; check on same charge but different date removed so each version is complete even if the charge does not change
+2 NEW IBX,IBBI,IBITEM,IBARR
SET IBX=0
+3 SET IBBI=$$CSBI^IBCRU3($GET(CS))
IF 'IBBI
SET IBX="3^Subfile/Set Error: No Billable Item for the Charge Set"
GOTO CHKDUPQ
+4 SET IBITEM=+$$ITPTR^IBCRU2(+IBBI,$PIECE($GET(IBLN),U,1))
+5 ; new NDC numbers
IF 'IBITEM
IF +IBBI=3
IF '$GET(ADD)
SET IBX=0
GOTO CHKDUPQ
+6 IF 'IBITEM
SET IBX="2^Line/Data Error: Item not found in source file"
GOTO CHKDUPQ
+7 IF $$FINDCI^IBCRU4(CS,IBITEM,$PIECE(IBLN,U,2),$PIECE(IBLN,U,5),$SELECT($$RVCD(CS,IBITEM):124,1:""),$JUSTIFY($PIECE(IBLN,U,4),"",2),,,$PIECE(IBLN,U,6))
SET IBX="2^Line/Data Error: Duplicate found, the same charge already exists for this item and effective date"
GOTO CHKDUPQ
+8 IF $$FINDCI^IBCRU4(CS,IBITEM,$PIECE(IBLN,U,2),$PIECE(IBLN,U,5))
SET IBX="1^Line/Data Warning: Potential duplicate, a charge already exists for this item and effective date"
GOTO CHKDUPQ
+9 ;I '$P(IBLN,U,3) D ITMCHG^IBCRCC(CS,IBITEM,$P(IBLN,U,2),$P(IBLN,U,5),.IBARR) I +IBARR=1,+$P(IBARR,U,2)=+$P(IBLN,U,4) S IBX="2^Line/Data Error: Charge for item is not modified by the new entry" G CHKDUPQ
CHKDUPQ QUIT IBX
+1 ;
CHKLN(BI,IBLN) ; check if data in line item is valid Billable Item
+1 ; Input: IBLN= item ^ eff dt ^ inact dt ^ charge ^ cpt modifier
+2 ; Output: if data not good: x ^ error description
+3 ; w/ x=1 - line/data warning - bad data but field not required
+4 ; x=2 - line/data error - bad required data, item can not be loaded into CM
+5 ; x=3 - subfile/set error stop all processing
+6 ; do not have to check if NDC is in source, since it is added if not there
+7 ; check on cpt-modifier pair removed with RC v2.0, charge pairings do not match official pairings
+8 NEW IBX,IBCSBR,IBITEM
SET IBX=0
+9 IF +$GET(BI)'=3
SET IBITEM=+$$ITPTR^IBCRU2(+$GET(BI),$PIECE($GET(IBLN),U,1))
IF 'IBITEM
SET IBX="2^Line/Data Error: Item not found in source file"
GOTO CHKLNQ
+10 IF +$GET(BI)'=3
IF '$$ITFILE^IBCRU2(+$GET(BI),IBITEM,$PIECE(IBLN,U,2))
SET IBX="2^Line/Data Error: Not a valid active Item in source file"
GOTO CHKLNQ
+11 IF +$GET(BI)=2
IF +$PIECE(IBLN,U,5)
IF '$PIECE($$MOD^ICPTMOD(+$PIECE(IBLN,U,5),"I",+$PIECE(IBLN,U,2)),U,7)
SET IBX="2^Line/Data Error: Not a valid active Modifier"
GOTO CHKLNQ
+12 ;I +$G(BI)=2,+$P(IBLN,U,5),+$$MODP^ICPTMOD(+IBITEM,+$P(IBLN,U,5),"I",$P(IBLN,U,2))<1 S IBX="2^Line/Data Error: Modifier "_$P($$MOD^ICPTMOD(+$P(IBLN,U,5),"I"),U,2)_" can not be used with CPT "_$P(IBLN,U,1) G CHKLNQ
+13 IF '$$VDATE($PIECE(IBLN,U,2))
SET IBX="2^Line/Data Error: Invalid Effective Date"
GOTO CHKLNQ
+14 IF $PIECE(IBLN,U,3)
IF '$$VDATE($PIECE(IBLN,U,3))
SET IBX="1^Line/Data Warning: Invalid Inactive Date"
GOTO CHKLNQ
CHKLNQ QUIT IBX
+1 ;
CHKFL(CS,FILE,IBSUBFL) ; Check the Charge Set and Host file are defined and match ok
+1 ; Output: if check is ok: 0
+2 ; if data not good: x ^ error description
+3 ; w/ x=3 - subfile/set error stop all processing
+4 NEW IBX,IBY,IBCSBI
SET IBX=0
+5 IF '$GET(CS)
SET IBX="3^Subfile/Set Error: No Charge Set Defined"
GOTO CHKFLQ
+6 SET IBCSBI=$$CSBI^IBCRU3(CS)
IF 'IBCSBI
SET IBX="3^Subfile/Set Error: No Billable Item for the Charge Set"
GOTO CHKFLQ
+7 ;
+8 IF $GET(FILE)=""
SET IBX="3^Subfile/Set Error: Invalid Host File Name"
GOTO CHKFLQ
+9 SET IBY=$GET(^XTMP(FILE,0))
IF IBY=""
SET IBX="3^Subfile/Set Error: Host File Name Not Defined"
GOTO CHKFLQ
+10 ;
+11 IF $GET(IBSUBFL)=""
SET IBX="3^Subfile/Set Error: Invalid Sub-File Name"
GOTO CHKFLQ
+12 SET IBY=$GET(^XTMP(FILE,IBSUBFL))
IF IBY=""
SET IBX="3^Subfile/Set Error: File Subset Not Defined"
GOTO CHKFLQ
+13 IF +IBCSBI'=+$PIECE(IBY,U,2)
SET IBX="3^Subfile/Set Error: Charge Set rate Billable Item ("_$PIECE(IBCSBI,U,2)_") does not match Host file Item ("_$$EXPAND^IBCRU1(363.3,.04,+$PIECE(IBY,U,2))_")"
GOTO CHKFLQ
CHKFLQ QUIT IBX
+1 ;
RVCD(CS,IBITEM) ; *634 - assign Revenue Code #124 to 5 ms-drg charges
+1 ; Input: charge set, charge item
+2 ; Output: 0 or 1
+3 NEW IBMHDG,IBCS0
SET IBMHDG=0
+4 SET IBCS0=$GET(^IBE(363.1,+$GET(CS),0))
if IBCS0=""
GOTO RVCDQ
+5 SET IBCS0=$PIECE(IBCS0,U,1)
+6 IF ($PIECE(IBCS0," ",1,2)'="RC-INPT R&B")!($LENGTH(IBCS0," ")'=3)
GOTO RVCDQ
+7 IF $FIND("^881^882^883^885^886^",(U_IBITEM_U))
SET IBMHDG=1
RVCDQ QUIT IBMHDG
+1 ;
VDATE(X) ; check for valid date, *667 check for valid year
+1 NEW Y
SET Y=0
IF +$GET(X)?7N
IF X>2801010
IF X<3491232
SET Y=1
+2 QUIT Y
