IBMHUT1 ;YMG/EDE - IB Mental Health Utilities ;MAY 15 2023
;;2.0;Integrated Billing;**784**;21-MAR-94;Build 8
;Per VA Directive 6402, this routine should not be modified.
;
Q
;
MHVST(IBSDT,IBEDT) ; loop through file 350 and populate file 351.83, as needed
;
; IBSDT - start date
; IBEDT - end date
;
N DFN,IBATYP,IBATYPN,IBCANC,IBDT,IBENC,IBEVDT,IBIEN,IBMHPROC,IBMHTRK,IBOK,IBSTAT,IBSTATN,IENS,N0,Z
I '+$G(IBSDT)!('+$G(IBEDT)) Q ; invalid date(s)
S DFN=0 F S DFN=$O(^IB("AFDT",DFN)) Q:'DFN D
.S IBDT=-(IBEDT+.01) F S IBDT=$O(^IB("AFDT",DFN,IBDT)) Q:'IBDT!(-IBDT<IBSDT) D
..S IBEVDT=-IBDT
..S IBIEN=0 F S IBIEN=$O(^IB("AFDT",DFN,IBDT,IBIEN)) Q:'IBIEN D
...S N0=$G(^IB(IBIEN,0)) ; file 350 entry, node 0
...S IBATYP=$P(N0,U,3) I 'IBATYP Q
...S IBATYPN=$P($G(^IBE(350.1,IBATYP,0)),U) I IBATYPN'["OPT" Q ; not an outpatient charge
...S IBSTAT=$P(N0,U,5) I 'IBSTAT Q
...S IBSTATN=$P($G(^IBE(350.21,IBSTAT,0)),U)
...S IBOK=$S(IBATYPN["CC MH":1,1:0)
...I 'IBOK S IBOK=$$ISCDCANC^IBECEAMH(IBIEN)
...I 'IBOK S Z=$P($P(N0,U,4),";") Q:$P(Z,":")'="409.68" S IBENC=$P(Z,":",2),IBOK=$$OECHK^IBECEAMH(IBENC,IBEVDT)
...I IBOK D
....; eligible for Cleland-Dole
....S IBMHTRK=+$O(^IBMH(351.83,"D",IBIEN,"")) ; file 351.83 ien, if entry already exists
....I IBSTATN="BILLED"!("^ON HOLD^HOLD - RATE^HOLD - REVIEW^"[(U_IBSTATN_U)),IBMHTRK>0,'$$ISBILLED(IBIEN) D ADDVST^IBECEAMH(DFN,IBEVDT,IBIEN,2)
....I IBSTATN="CANCELLED" D
.....S IBCANC=+$P(N0,U,10) I 'IBCANC Q
.....S IENS=IBCANC_",",IBMHPROC=$$GET1^DIQ(350.3,IENS,.07,"I") I 'IBMHPROC Q
.....I '$$GET1^DIQ(350.3,IENS,.08,"I") Q ; cancellation reason can't cancel C-D charge
.....I IBMHTRK>0 D UPDVST^IBECEAMH(IBIEN,IBMHPROC) Q
.....I $P(^IBE(350.3,IBCANC,0),U)="CLELAND-DOLE",$$NUMVSTCK^IBECEAMH(DFN,IBEVDT) D ADDVST^IBECEAMH(DFN,IBEVDT,IBIEN,1,2)
....Q
...Q
..Q
.Q
Q
;
ISBILLED(IBIEN) ; check if there's a "billed" entry in file 351.83 for a given charge
;
; IBIEN - file 350 ien
;
; returns 1 if there's a corresponding entry in file 351.83 with "billed" status, or 0 otherwise.
;
N IBMHIEN,RES
S (RES,IBMHIEN)=0 F S IBMHIEN=$O(^IBMH(351.83,"D",IBIEN,IBMHIEN)) Q:'IBMHIEN!RES I $P(^IBMH(351.83,IBMHIEN,0),U,4)=2 S RES=1
Q RES
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBMHUT1 2272 printed Dec 13, 2024@02:24:30 Page 2
IBMHUT1 ;YMG/EDE - IB Mental Health Utilities ;MAY 15 2023
+1 ;;2.0;Integrated Billing;**784**;21-MAR-94;Build 8
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;
MHVST(IBSDT,IBEDT) ; loop through file 350 and populate file 351.83, as needed
+1 ;
+2 ; IBSDT - start date
+3 ; IBEDT - end date
+4 ;
+5 NEW DFN,IBATYP,IBATYPN,IBCANC,IBDT,IBENC,IBEVDT,IBIEN,IBMHPROC,IBMHTRK,IBOK,IBSTAT,IBSTATN,IENS,N0,Z
+6 ; invalid date(s)
IF '+$GET(IBSDT)!('+$GET(IBEDT))
QUIT
+7 SET DFN=0
FOR
SET DFN=$ORDER(^IB("AFDT",DFN))
if 'DFN
QUIT
Begin DoDot:1
+8 SET IBDT=-(IBEDT+.01)
FOR
SET IBDT=$ORDER(^IB("AFDT",DFN,IBDT))
if 'IBDT!(-IBDT<IBSDT)
QUIT
Begin DoDot:2
+9 SET IBEVDT=-IBDT
+10 SET IBIEN=0
FOR
SET IBIEN=$ORDER(^IB("AFDT",DFN,IBDT,IBIEN))
if 'IBIEN
QUIT
Begin DoDot:3
+11 ; file 350 entry, node 0
SET N0=$GET(^IB(IBIEN,0))
+12 SET IBATYP=$PIECE(N0,U,3)
IF 'IBATYP
QUIT
+13 ; not an outpatient charge
SET IBATYPN=$PIECE($GET(^IBE(350.1,IBATYP,0)),U)
IF IBATYPN'["OPT"
QUIT
+14 SET IBSTAT=$PIECE(N0,U,5)
IF 'IBSTAT
QUIT
+15 SET IBSTATN=$PIECE($GET(^IBE(350.21,IBSTAT,0)),U)
+16 SET IBOK=$SELECT(IBATYPN["CC MH":1,1:0)
+17 IF 'IBOK
SET IBOK=$$ISCDCANC^IBECEAMH(IBIEN)
+18 IF 'IBOK
SET Z=$PIECE($PIECE(N0,U,4),";")
if $PIECE(Z,"
QUIT
SET IBENC=$PIECE(Z,":",2)
SET IBOK=$$OECHK^IBECEAMH(IBENC,IBEVDT)
+19 IF IBOK
Begin DoDot:4
+20 ; eligible for Cleland-Dole
+21 ; file 351.83 ien, if entry already exists
SET IBMHTRK=+$ORDER(^IBMH(351.83,"D",IBIEN,""))
+22 IF IBSTATN="BILLED"!("^ON HOLD^HOLD - RATE^HOLD - REVIEW^"[(U_IBSTATN_U))
IF IBMHTRK>0
IF '$$ISBILLED(IBIEN)
DO ADDVST^IBECEAMH(DFN,IBEVDT,IBIEN,2)
+23 IF IBSTATN="CANCELLED"
Begin DoDot:5
+24 SET IBCANC=+$PIECE(N0,U,10)
IF 'IBCANC
QUIT
+25 SET IENS=IBCANC_","
SET IBMHPROC=$$GET1^DIQ(350.3,IENS,.07,"I")
IF 'IBMHPROC
QUIT
+26 ; cancellation reason can't cancel C-D charge
IF '$$GET1^DIQ(350.3,IENS,.08,"I")
QUIT
+27 IF IBMHTRK>0
DO UPDVST^IBECEAMH(IBIEN,IBMHPROC)
QUIT
+28 IF $PIECE(^IBE(350.3,IBCANC,0),U)="CLELAND-DOLE"
IF $$NUMVSTCK^IBECEAMH(DFN,IBEVDT)
DO ADDVST^IBECEAMH(DFN,IBEVDT,IBIEN,1,2)
End DoDot:5
+29 QUIT
End DoDot:4
+30 QUIT
End DoDot:3
+31 QUIT
End DoDot:2
+32 QUIT
End DoDot:1
+33 QUIT
+34 ;
ISBILLED(IBIEN) ; check if there's a "billed" entry in file 351.83 for a given charge
+1 ;
+2 ; IBIEN - file 350 ien
+3 ;
+4 ; returns 1 if there's a corresponding entry in file 351.83 with "billed" status, or 0 otherwise.
+5 ;
+6 NEW IBMHIEN,RES
+7 SET (RES,IBMHIEN)=0
FOR
SET IBMHIEN=$ORDER(^IBMH(351.83,"D",IBIEN,IBMHIEN))
if 'IBMHIEN!RES
QUIT
IF $PIECE(^IBMH(351.83,IBMHIEN,0),U,4)=2
SET RES=1
+8 QUIT RES
