IBCBB5 ;ALB/BGA - CONT OF MEDICARE EDIT CHECKS ;08/12/98
;;2.0;INTEGRATED BILLING;**51,137,371,718**;21-MAR-94;Build 73
;;Per VHA Directive 2004-038, this routine should not be modified.
;
D F^IBCEF("N-ADMISSION DATE","IBZADMIT",,IBIFN)
D F^IBCEF("N-DISCHARGE DATE","IBZDISCH",,IBIFN)
;
; Occurrence Code and Dates
; occ codes can not be duplicates for same dates and must have a date
K IBXSAVE,IBXDATA D F^IBCEF("N-OCCURRENCE CODES",,,IBIFN)
; Returns arrays IBXSAVE("OCC",n) AND IBXSAVE("OCCS",n) =
; code^start date^state^end date
; IBOCS=occ codes ;; IBOCSP=occ span codes
;
S IBI=0 F S IBI=$O(IBXSAVE("OCCS",IBI)) Q:'IBI D
. N IBOCSDT,IBOCSDT1,Z
. S IBOCSDT=$P(IBXSAVE("OCCS",IBI),U,2),IBOCSDT1=$P(IBXSAVE("OCCS",IBI),U,3),IBOCCS=$P(IBXSAVE("OCCS",IBI),U)
. S IBOCSP(IBOCCS,$O(IBOCSP(IBOCCS,""),-1)+1)=IBXSAVE("OCCS",IBI)
. ; Occurrence Code End dates must be > start date and are required for OCCURANCE SPANS
. I 'IBOCSDT1 S IBER=IBER_"IB155;" Q
. I IBOCSDT1<IBOCSDT S IBER=IBER_"IB150;" Q
;
S IBI=0 F S IBI=$O(IBXSAVE("OCC",IBI)) Q:'IBI D
. N Z
. S IBOCCD=$P(IBXSAVE("OCC",IBI),U)
. S IBOCCD(IBOCCD,$O(IBOCCD(IBOCCD,""),-1)+1)=IBXSAVE("OCC",IBI)
. I IBOCCD=10 S ^TMP($J,"LMD")=1
Q:IBQUIT
;
; For type of admit = 1 or 2, at least one occ code 1-6, 10, or 11 req
I $P(IBNDU,U,8)=1!($P(IBNDU,U,8)=2) D
. N OK
. S OK=0
. F Z="01","02","03","04","05","06",10,11 I $D(IBOCCD(Z))!($D(IBOCCD(+Z))) S OK=1 Q
. I 'OK S IBQUIT=$$IBER^IBCBB3(.IBER,133)
K IBXDATA D F^IBCEF("N-VALUE CODES",,,IBIFN)
S IBX=0
N IBVCIEN,IBVCSCREEN,IBVCVALUE ;WCJ;IB718;SQA
F S IBX=$O(IBXDATA(IBX)) Q:'IBX D Q:IBQUIT
. I '$D(IBVALCD($P(IBXDATA(IBX),U))) S IBVALCD($P(IBXDATA(IBX),U))=$P(IBXDATA(IBX),U,2)
. ; value code 01 must have a value>0
. I $P(IBXDATA(IBX),U)="01",IBER'["134;",$P(IBXDATA(IBX),U,2)'>0 S IBQUIT=$$IBER^IBCBB3(.IBER,134) Q
. ; value code 02 must have a value=0
. I $P(IBXDATA(IBX),U)="02",IBER'["135;",+$P(IBXDATA(IBX),U,2)'=0 S IBQUIT=$$IBER^IBCBB3(.IBER,135) Q
. ; code^amount^dollar amt flag (1=amt,0=quantity)
. I $P(IBXDATA(IBX),U,2)="",IBER'["157;" S IBQUIT=$$IBER^IBCBB3(.IBER,157) Q
. I '$$CHK^IBCVC($P(IBXDATA(IBX),U,4),$P(IBXDATA(IBX),U,2)),IBER'["158;" S IBQUIT=$$IBER^IBCBB3(.IBER,158) Q
. ;
. ;TPF;IB*2.0*718;EBILL-1570;11/03/2021
. S IBVCIEN=$P(IBXDATA(IBX),U,4)
. I IBVCIEN S IBVCSCREEN=$G(^DGCR(399.1,IBVCIEN,2))
. I IBVCSCREEN'="" D
.. S IBVCVALUE=$P(IBXDATA(IBX),U,2)
.. K IBVCERR X IBVCSCREEN
.. I $G(IBVCERR) Q
. ;END;TPF;IB*2.0*718;EBILL-1570;11/03/2021
;
Q:IBQUIT
; Must have acc hr if accident is indicated on inpatient bill
I $$INPAT^IBCEF(IBIFN,1) D
. I $D(IBOCCD("01"))!$D(IBOCCD("02"))!$D(IBOCCD("03"))!$D(IBOCCD("04"))!$D(IBOCCD("05")) D
.. I '$D(IBVALCD(45)),'$P($G(^DGCR(399,IBIFN,"U")),U,10) S IBQUIT=$$IBER^IBCBB3(.IBER,156)
Q:IBQUIT
;
D ^IBCBB6
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCBB5 2921 printed Oct 16, 2024@18:09:35 Page 2
IBCBB5 ;ALB/BGA - CONT OF MEDICARE EDIT CHECKS ;08/12/98
+1 ;;2.0;INTEGRATED BILLING;**51,137,371,718**;21-MAR-94;Build 73
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 DO F^IBCEF("N-ADMISSION DATE","IBZADMIT",,IBIFN)
+5 DO F^IBCEF("N-DISCHARGE DATE","IBZDISCH",,IBIFN)
+6 ;
+7 ; Occurrence Code and Dates
+8 ; occ codes can not be duplicates for same dates and must have a date
+9 KILL IBXSAVE,IBXDATA
DO F^IBCEF("N-OCCURRENCE CODES",,,IBIFN)
+10 ; Returns arrays IBXSAVE("OCC",n) AND IBXSAVE("OCCS",n) =
+11 ; code^start date^state^end date
+12 ; IBOCS=occ codes ;; IBOCSP=occ span codes
+13 ;
+14 SET IBI=0
FOR
SET IBI=$ORDER(IBXSAVE("OCCS",IBI))
if 'IBI
QUIT
Begin DoDot:1
+15 NEW IBOCSDT,IBOCSDT1,Z
+16 SET IBOCSDT=$PIECE(IBXSAVE("OCCS",IBI),U,2)
SET IBOCSDT1=$PIECE(IBXSAVE("OCCS",IBI),U,3)
SET IBOCCS=$PIECE(IBXSAVE("OCCS",IBI),U)
+17 SET IBOCSP(IBOCCS,$ORDER(IBOCSP(IBOCCS,""),-1)+1)=IBXSAVE("OCCS",IBI)
+18 ; Occurrence Code End dates must be > start date and are required for OCCURANCE SPANS
+19 IF 'IBOCSDT1
SET IBER=IBER_"IB155;"
QUIT
+20 IF IBOCSDT1<IBOCSDT
SET IBER=IBER_"IB150;"
QUIT
End DoDot:1
+21 ;
+22 SET IBI=0
FOR
SET IBI=$ORDER(IBXSAVE("OCC",IBI))
if 'IBI
QUIT
Begin DoDot:1
+23 NEW Z
+24 SET IBOCCD=$PIECE(IBXSAVE("OCC",IBI),U)
+25 SET IBOCCD(IBOCCD,$ORDER(IBOCCD(IBOCCD,""),-1)+1)=IBXSAVE("OCC",IBI)
+26 IF IBOCCD=10
SET ^TMP($JOB,"LMD")=1
End DoDot:1
+27 if IBQUIT
QUIT
+28 ;
+29 ; For type of admit = 1 or 2, at least one occ code 1-6, 10, or 11 req
+30 IF $PIECE(IBNDU,U,8)=1!($PIECE(IBNDU,U,8)=2)
Begin DoDot:1
+31 NEW OK
+32 SET OK=0
+33 FOR Z="01","02","03","04","05","06",10,11
IF $DATA(IBOCCD(Z))!($DATA(IBOCCD(+Z)))
SET OK=1
QUIT
+34 IF 'OK
SET IBQUIT=$$IBER^IBCBB3(.IBER,133)
End DoDot:1
+35 KILL IBXDATA
DO F^IBCEF("N-VALUE CODES",,,IBIFN)
+36 SET IBX=0
+37 ;WCJ;IB718;SQA
NEW IBVCIEN,IBVCSCREEN,IBVCVALUE
+38 FOR
SET IBX=$ORDER(IBXDATA(IBX))
if 'IBX
QUIT
Begin DoDot:1
+39 IF '$DATA(IBVALCD($PIECE(IBXDATA(IBX),U)))
SET IBVALCD($PIECE(IBXDATA(IBX),U))=$PIECE(IBXDATA(IBX),U,2)
+40 ; value code 01 must have a value>0
+41 IF $PIECE(IBXDATA(IBX),U)="01"
IF IBER'["134;"
IF $PIECE(IBXDATA(IBX),U,2)'>0
SET IBQUIT=$$IBER^IBCBB3(.IBER,134)
QUIT
+42 ; value code 02 must have a value=0
+43 IF $PIECE(IBXDATA(IBX),U)="02"
IF IBER'["135;"
IF +$PIECE(IBXDATA(IBX),U,2)'=0
SET IBQUIT=$$IBER^IBCBB3(.IBER,135)
QUIT
+44 ; code^amount^dollar amt flag (1=amt,0=quantity)
+45 IF $PIECE(IBXDATA(IBX),U,2)=""
IF IBER'["157;"
SET IBQUIT=$$IBER^IBCBB3(.IBER,157)
QUIT
+46 IF '$$CHK^IBCVC($PIECE(IBXDATA(IBX),U,4),$PIECE(IBXDATA(IBX),U,2))
IF IBER'["158;"
SET IBQUIT=$$IBER^IBCBB3(.IBER,158)
QUIT
+47 ;
+48 ;TPF;IB*2.0*718;EBILL-1570;11/03/2021
+49 SET IBVCIEN=$PIECE(IBXDATA(IBX),U,4)
+50 IF IBVCIEN
SET IBVCSCREEN=$GET(^DGCR(399.1,IBVCIEN,2))
+51 IF IBVCSCREEN'=""
Begin DoDot:2
+52 SET IBVCVALUE=$PIECE(IBXDATA(IBX),U,2)
+53 KILL IBVCERR
XECUTE IBVCSCREEN
+54 IF $GET(IBVCERR)
QUIT
End DoDot:2
+55 ;END;TPF;IB*2.0*718;EBILL-1570;11/03/2021
End DoDot:1
if IBQUIT
QUIT
+56 ;
+57 if IBQUIT
QUIT
+58 ; Must have acc hr if accident is indicated on inpatient bill
+59 IF $$INPAT^IBCEF(IBIFN,1)
Begin DoDot:1
+60 IF $DATA(IBOCCD("01"))!$DATA(IBOCCD("02"))!$DATA(IBOCCD("03"))!$DATA(IBOCCD("04"))!$DATA(IBOCCD("05"))
Begin DoDot:2
+61 IF '$DATA(IBVALCD(45))
IF '$PIECE($GET(^DGCR(399,IBIFN,"U")),U,10)
SET IBQUIT=$$IBER^IBCBB3(.IBER,156)
End DoDot:2
End DoDot:1
+62 if IBQUIT
QUIT
+63 ;
+64 DO ^IBCBB6
+65 QUIT
