IBPF1 ;ALB/CPM - FIND BILLING DATA TO ARCHIVE (CON'T.) ; 20-APR-92
;;2.0;INTEGRATED BILLING;**45,347**;21-MAR-94;Build 24
;;Per VHA Directive 2004-038, this routine should not be modified.
;
BILL ; Find all UB-82's which may be archived. Check only those bills
; whose First Printed Date is prior to the last date on which a
; bill must have been closed out in Accounts Receivable.
;
; Input: IBEDT -- last valid date on which a bill may be closed out
; IBTMPL -- search template in which to store entries
; Output: IBCNT -- number of IB Actions which may be archived.
;
S (IBDT,IBN)="",IBCNT=0
F S IBDT=$O(^DGCR(399,"AP",IBDT)) Q:'IBDT!(IBDT>IBEDT) F S IBN=$O(^DGCR(399,"AP",IBDT,IBN)) Q:'IBN I $$ALL(IBN,IBEDT) S IBCNT=IBCNT+1,^DIBT(IBTMPL,1,IBN)=""
K IBCLO,IBDT,IBN
Q
;
;
IB ; Find Pharmacy Co-pay IB Actions which may be archived. Check
; only those Pharmacy Co-pay IB Actions which have been added to the
; database prior to the last date on which a bill must have been
; closed out in Accounts Receivable. Only "parent actions" will
; be checked, and if the parent action may be archived, the parent
; and its "children" will all be marked for archiving.
;
; Input: IBEDT -- last valid date on which a bill may be closed out
; IBTMPL -- search template in which to store entries
; Output: IBCNT -- number of IB Actions which may be archived.
;
; - first find all Pharmacy action types.
K IBA F I=1:1 S IBATYPN=$P($T(PSO+I),";;",2,99) Q:IBATYPN="" S IBATYP=$O(^IBE(350.1,"B",IBATYPN,0)) I IBATYP S IBA(IBATYP)=""
;
; - locate all Pharmacy Co-pay actions which may be archived.
S (IBDT,IBN)="",IBCNT=0
F S IBDT=$O(^IB("D",IBDT)) Q:'IBDT!(IBDT>(IBEDT+.3)) D
. F S IBN=$O(^IB("D",IBDT,IBN)) Q:'IBN D:$D(^IB("AD",IBN))
.. S IBND=$G(^IB(IBN,0)) Q:IBND="" ; 0th node missing
.. Q:'$D(IBA(+$P(IBND,"^",3))) ; not a Pharmacy co-pay action
.. Q:$$RXFILE(IBND) ; billed prescription has not been archived
.. S IBAR=$P(IBND,"^",11) Q:IBAR=""
.. S X="RCFN03" X ^%ZOSF("TEST")
.. S IBAR=$S($T:$$BIEN^RCFN03(IBAR),1:$O(^PRCA(430,"B",IBAR,0)))
.. I IBAR,$$CLO(IBAR,IBEDT) F DA=0:0 S DA=$O(^IB("AD",IBN,DA)) Q:'DA S IBCNT=IBCNT+1,^DIBT(IBTMPL,1,DA)=""
;
; - kill variables and quit.
K DA,IBA,IBAR,IBATYP,IBATYPN,IBCLO,IBDT,IBN,IBND,X
Q
;
;
RXFILE(IBND) ; Is the prescription still resident on-line?
; Input: IBND -- zeroth node of IB Action
; Output: 1 -- the rx is still on file
; 0 -- the rx is no longer on file (archived)
N IBSL,RXCHK
S IBSL=$P(IBND,"^",4) I +IBSL'=52 Q 0
S IBSL=$P(IBSL,":",2)
S RXCHK=$$FILE^IBRXUTL(+IBSL,.01)
I RXCHK'="" Q 1
Q 0
;
ALL(IBN,DATE) ; Are all bills for an episode of care closed before DATE?
; Input: IBN -- ien of bill in file #399
; DATE -- the date by which the bills must be closed
; Output: 1 -- all bills are closed
; 0 -- at least one bill is not closed
N I,X
S X=$$CLO(IBN,DATE)
I X S I=0 F S I=$O(^DGCR(399,"AC",IBN,I)) Q:'I I I'=IBN,'$$CLO(I,DATE) S X=0 Q
Q X
;
CLO(IBN,DATE) ; Is the bill closed before DATE?
; Input: IBN -- ien of bill in file #399
; DATE -- the date by which the bill must be closed
; Output: 1 -- the bill is closed
; 0 -- the bill is not closed
N CLO S CLO=$$PUR^PRCAFN(IBN)
Q $S(CLO=-2:1,CLO=-1:0,1:CLO'>DATE)
;
;
PSO ; Pharmacy Co-pay Action Types
;;PSO NSC RX COPAY CANCEL
;;PSO NSC RX COPAY NEW
;;PSO NSC RX COPAY UPDATE
;;PSO SC RX COPAY CANCEL
;;PSO SC RX COPAY NEW
;;PSO SC RX COPAY UPDATE
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBPF1 3777 printed Apr 09, 2024@21:23:07 Page 2
IBPF1 ;ALB/CPM - FIND BILLING DATA TO ARCHIVE (CON'T.) ; 20-APR-92
+1 ;;2.0;INTEGRATED BILLING;**45,347**;21-MAR-94;Build 24
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
BILL ; Find all UB-82's which may be archived. Check only those bills
+1 ; whose First Printed Date is prior to the last date on which a
+2 ; bill must have been closed out in Accounts Receivable.
+3 ;
+4 ; Input: IBEDT -- last valid date on which a bill may be closed out
+5 ; IBTMPL -- search template in which to store entries
+6 ; Output: IBCNT -- number of IB Actions which may be archived.
+7 ;
+8 SET (IBDT,IBN)=""
SET IBCNT=0
+9 FOR
SET IBDT=$ORDER(^DGCR(399,"AP",IBDT))
if 'IBDT!(IBDT>IBEDT)
QUIT
FOR
SET IBN=$ORDER(^DGCR(399,"AP",IBDT,IBN))
if 'IBN
QUIT
IF $$ALL(IBN,IBEDT)
SET IBCNT=IBCNT+1
SET ^DIBT(IBTMPL,1,IBN)=""
+10 KILL IBCLO,IBDT,IBN
+11 QUIT
+12 ;
+13 ;
IB ; Find Pharmacy Co-pay IB Actions which may be archived. Check
+1 ; only those Pharmacy Co-pay IB Actions which have been added to the
+2 ; database prior to the last date on which a bill must have been
+3 ; closed out in Accounts Receivable. Only "parent actions" will
+4 ; be checked, and if the parent action may be archived, the parent
+5 ; and its "children" will all be marked for archiving.
+6 ;
+7 ; Input: IBEDT -- last valid date on which a bill may be closed out
+8 ; IBTMPL -- search template in which to store entries
+9 ; Output: IBCNT -- number of IB Actions which may be archived.
+10 ;
+11 ; - first find all Pharmacy action types.
+12 KILL IBA
FOR I=1:1
SET IBATYPN=$PIECE($TEXT(PSO+I),";;",2,99)
if IBATYPN=""
QUIT
SET IBATYP=$ORDER(^IBE(350.1,"B",IBATYPN,0))
IF IBATYP
SET IBA(IBATYP)=""
+13 ;
+14 ; - locate all Pharmacy Co-pay actions which may be archived.
+15 SET (IBDT,IBN)=""
SET IBCNT=0
+16 FOR
SET IBDT=$ORDER(^IB("D",IBDT))
if 'IBDT!(IBDT>(IBEDT+.3))
QUIT
Begin DoDot:1
+17 FOR
SET IBN=$ORDER(^IB("D",IBDT,IBN))
if 'IBN
QUIT
if $DATA(^IB("AD",IBN))
Begin DoDot:2
+18 ; 0th node missing
SET IBND=$GET(^IB(IBN,0))
if IBND=""
QUIT
+19 ; not a Pharmacy co-pay action
if '$DATA(IBA(+$PIECE(IBND,"^",3)))
QUIT
+20 ; billed prescription has not been archived
if $$RXFILE(IBND)
QUIT
+21 SET IBAR=$PIECE(IBND,"^",11)
if IBAR=""
QUIT
+22 SET X="RCFN03"
XECUTE ^%ZOSF("TEST")
+23 SET IBAR=$SELECT($TEST:$$BIEN^RCFN03(IBAR),1:$ORDER(^PRCA(430,"B",IBAR,0)))
+24 IF IBAR
IF $$CLO(IBAR,IBEDT)
FOR DA=0:0
SET DA=$ORDER(^IB("AD",IBN,DA))
if 'DA
QUIT
SET IBCNT=IBCNT+1
SET ^DIBT(IBTMPL,1,DA)=""
End DoDot:2
End DoDot:1
+25 ;
+26 ; - kill variables and quit.
+27 KILL DA,IBA,IBAR,IBATYP,IBATYPN,IBCLO,IBDT,IBN,IBND,X
+28 QUIT
+29 ;
+30 ;
RXFILE(IBND) ; Is the prescription still resident on-line?
+1 ; Input: IBND -- zeroth node of IB Action
+2 ; Output: 1 -- the rx is still on file
+3 ; 0 -- the rx is no longer on file (archived)
+4 NEW IBSL,RXCHK
+5 SET IBSL=$PIECE(IBND,"^",4)
IF +IBSL'=52
QUIT 0
+6 SET IBSL=$PIECE(IBSL,":",2)
+7 SET RXCHK=$$FILE^IBRXUTL(+IBSL,.01)
+8 IF RXCHK'=""
QUIT 1
+9 QUIT 0
+10 ;
ALL(IBN,DATE) ; Are all bills for an episode of care closed before DATE?
+1 ; Input: IBN -- ien of bill in file #399
+2 ; DATE -- the date by which the bills must be closed
+3 ; Output: 1 -- all bills are closed
+4 ; 0 -- at least one bill is not closed
+5 NEW I,X
+6 SET X=$$CLO(IBN,DATE)
+7 IF X
SET I=0
FOR
SET I=$ORDER(^DGCR(399,"AC",IBN,I))
if 'I
QUIT
IF I'=IBN
IF '$$CLO(I,DATE)
SET X=0
QUIT
+8 QUIT X
+9 ;
CLO(IBN,DATE) ; Is the bill closed before DATE?
+1 ; Input: IBN -- ien of bill in file #399
+2 ; DATE -- the date by which the bill must be closed
+3 ; Output: 1 -- the bill is closed
+4 ; 0 -- the bill is not closed
+5 NEW CLO
SET CLO=$$PUR^PRCAFN(IBN)
+6 QUIT $SELECT(CLO=-2:1,CLO=-1:0,1:CLO'>DATE)
+7 ;
+8 ;
PSO ; Pharmacy Co-pay Action Types
+1 ;;PSO NSC RX COPAY CANCEL
+2 ;;PSO NSC RX COPAY NEW
+3 ;;PSO NSC RX COPAY UPDATE
+4 ;;PSO SC RX COPAY CANCEL
+5 ;;PSO SC RX COPAY NEW
+6 ;;PSO SC RX COPAY UPDATE
+7 ;
