- 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 Feb 18, 2025@23:46:01 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