- 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 Mar 13, 2025@21:13:44 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
