IBTRKR31 ;ALB/AAS - CLAIMS TRACKING - DBLCHK RX FILLS ; 13-AUG-93
;;2.0;INTEGRATED BILLING;**33,121,160,309,347,405**;21-MAR-94;Build 4
;;Per VHA Directive 2004-038, this routine should not be modified.
;
% ; -- Double check rx data routine
DBLCHK(IBTRN) ; -- double check rx before billing, input tracking id
N IBX,IBFILL,IBFILLD,IBRXN,IBTRND,IBRMARK,IBRXSTAT,IBDEA,IBDRUG,IBRXDATA,X,Y,IBY,IBDFN
S IBX=0
S IBTRND=$G(^IBT(356,+IBTRN,0)) I IBTRND="" G DBLCHKQ
S IBRXN=$P(IBTRND,"^",8),IBFILL=$P(IBTRND,"^",10),IBFILLD=""
;
S IBDFN=$$FILE^IBRXUTL(IBRXN,2)
I IBFILL=0 S IBY=$$RXSEC^IBRXUTL(IBDFN,IBRXN),IBFILLD=$P(IBY,U,2)_U_$P(IBY,U,13)_U_$P(IBY,U,15)
I IBFILL>0 S IBY=$$ZEROSUB^IBRXUTL(IBDFN,IBRXN,IBFILL),IBFILLD=$P(IBY,U,1)_U_$P(IBY,U,18)_U_$P(IBY,U,16)
;
I (IBFILL'>0&(IBFILL'=0))!(IBRXN<1) S IBRMARK="INVALID PRESCRIPTION ENTRY" G DBLCHKQ
;
S IBRXDATA=$$RXZERO^IBRXUTL(IBDFN,IBRXN),IBRXSTAT=$P(IBRXDATA,"^",15)
;S DFN=+$P(IBRXDATA,"^",2),IBDT=+IBFILLD
;I IBDT=$P($O(^DPT(DFN,"S",(IBDT-.00001))),".") S IBRMARK="REFILL ON VISIT DATE" G DBLCHKQ
;
; -- check rx status (not deleted)
I IBRXSTAT=13 S IBRMARK="PRESCRIPTION DELETED" G DBLCHKQ
;
; -- refill not released or returned to stock
I '$P(IBFILLD,"^",2) S IBRMARK="PRESCRIPTION NOT RELEASED" G DBLCHKQ
I $P(IBFILLD,"^",3) S IBRMARK="PRESCRIPTION NOT RELEASED" G DBLCHKQ
;
; -- check drug (not investigational, supply, or over the counter drug
S IBDRUG=$P(IBRXDATA,"^",6)
D ZERO^IBRXUTL(IBDRUG)
S IBDEA=$G(^TMP($J,"IBDRUG",+IBDRUG,3))
I IBDEA["I"!(IBDEA["S")!(IBDEA["9")!(IBDEA["N") S IBRMARK="DRUG NOT BILLABLE" G DBLCHKQ ; investigational drug, supply or otc
;
S IBX=1
K ^TMP($J,"IBDRUG")
;
DBLCHKQ I $G(IBRMARK)]"" D
.S IBRMARK=$O(^IBE(356.8,"B",IBRMARK,0)) I 'IBRMARK S IBRMARK=999
.N DA,DR,DIC,DIE
.L +^IBT(356,+IBTRN):5 I '$T Q
.S DA=IBTRN,DIE="^IBT(356,",DR=".19////"_IBRMARK
.D ^DIE
.L -^IBT(356,+IBTRN)
Q IBX
;
;
BULL ; -- send bulletin
;
S XMSUB="Rx Refills added to Claims Tracking Complete"
S IBT(1)="The process to automatically add Rx Refills has successfully completed."
S IBT(1.1)=""
S IBT(2)=" Start Date: "_$$DAT1^IBOUTL(IBTSBDT)
S IBT(3)=" End Date: "_$$DAT1^IBOUTL(IBTSEDT)
I $D(IBMESS) S IBT(3.1)=IBMESS
S IBT(4)=""
S IBT(5)=" Total Rx fills checked: "_$G(IBCNT)
S IBT(6)="Total NSC Rx fills Added: "_$G(IBCNT1)
S IBT(7)=" Total SC Rx fills Added: "_$G(IBCNT2)
S IBT(8)=""
S IBT(9)="*The fills added as SC require determination and editing to be billed"
D SEND
BULLQ Q
;
SEND S XMDUZ="INTEGRATED BILLING PACKAGE",XMTEXT="IBT("
K XMY S XMN=0
S XMY(DUZ)=""
D ^XMD
K X,Y,IBI,IBT,IBGRP,XMDUZ,XMTEXT,XMY,XMSUB
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBTRKR31 2745 printed Dec 13, 2024@02:28:40 Page 2
IBTRKR31 ;ALB/AAS - CLAIMS TRACKING - DBLCHK RX FILLS ; 13-AUG-93
+1 ;;2.0;INTEGRATED BILLING;**33,121,160,309,347,405**;21-MAR-94;Build 4
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
% ; -- Double check rx data routine
DBLCHK(IBTRN) ; -- double check rx before billing, input tracking id
+1 NEW IBX,IBFILL,IBFILLD,IBRXN,IBTRND,IBRMARK,IBRXSTAT,IBDEA,IBDRUG,IBRXDATA,X,Y,IBY,IBDFN
+2 SET IBX=0
+3 SET IBTRND=$GET(^IBT(356,+IBTRN,0))
IF IBTRND=""
GOTO DBLCHKQ
+4 SET IBRXN=$PIECE(IBTRND,"^",8)
SET IBFILL=$PIECE(IBTRND,"^",10)
SET IBFILLD=""
+5 ;
+6 SET IBDFN=$$FILE^IBRXUTL(IBRXN,2)
+7 IF IBFILL=0
SET IBY=$$RXSEC^IBRXUTL(IBDFN,IBRXN)
SET IBFILLD=$PIECE(IBY,U,2)_U_$PIECE(IBY,U,13)_U_$PIECE(IBY,U,15)
+8 IF IBFILL>0
SET IBY=$$ZEROSUB^IBRXUTL(IBDFN,IBRXN,IBFILL)
SET IBFILLD=$PIECE(IBY,U,1)_U_$PIECE(IBY,U,18)_U_$PIECE(IBY,U,16)
+9 ;
+10 IF (IBFILL'>0&(IBFILL'=0))!(IBRXN<1)
SET IBRMARK="INVALID PRESCRIPTION ENTRY"
GOTO DBLCHKQ
+11 ;
+12 SET IBRXDATA=$$RXZERO^IBRXUTL(IBDFN,IBRXN)
SET IBRXSTAT=$PIECE(IBRXDATA,"^",15)
+13 ;S DFN=+$P(IBRXDATA,"^",2),IBDT=+IBFILLD
+14 ;I IBDT=$P($O(^DPT(DFN,"S",(IBDT-.00001))),".") S IBRMARK="REFILL ON VISIT DATE" G DBLCHKQ
+15 ;
+16 ; -- check rx status (not deleted)
+17 IF IBRXSTAT=13
SET IBRMARK="PRESCRIPTION DELETED"
GOTO DBLCHKQ
+18 ;
+19 ; -- refill not released or returned to stock
+20 IF '$PIECE(IBFILLD,"^",2)
SET IBRMARK="PRESCRIPTION NOT RELEASED"
GOTO DBLCHKQ
+21 IF $PIECE(IBFILLD,"^",3)
SET IBRMARK="PRESCRIPTION NOT RELEASED"
GOTO DBLCHKQ
+22 ;
+23 ; -- check drug (not investigational, supply, or over the counter drug
+24 SET IBDRUG=$PIECE(IBRXDATA,"^",6)
+25 DO ZERO^IBRXUTL(IBDRUG)
+26 SET IBDEA=$GET(^TMP($JOB,"IBDRUG",+IBDRUG,3))
+27 ; investigational drug, supply or otc
IF IBDEA["I"!(IBDEA["S")!(IBDEA["9")!(IBDEA["N")
SET IBRMARK="DRUG NOT BILLABLE"
GOTO DBLCHKQ
+28 ;
+29 SET IBX=1
+30 KILL ^TMP($JOB,"IBDRUG")
+31 ;
DBLCHKQ IF $GET(IBRMARK)]""
Begin DoDot:1
+1 SET IBRMARK=$ORDER(^IBE(356.8,"B",IBRMARK,0))
IF 'IBRMARK
SET IBRMARK=999
+2 NEW DA,DR,DIC,DIE
+3 LOCK +^IBT(356,+IBTRN):5
IF '$TEST
QUIT
+4 SET DA=IBTRN
SET DIE="^IBT(356,"
SET DR=".19////"_IBRMARK
+5 DO ^DIE
+6 LOCK -^IBT(356,+IBTRN)
End DoDot:1
+7 QUIT IBX
+8 ;
+9 ;
BULL ; -- send bulletin
+1 ;
+2 SET XMSUB="Rx Refills added to Claims Tracking Complete"
+3 SET IBT(1)="The process to automatically add Rx Refills has successfully completed."
+4 SET IBT(1.1)=""
+5 SET IBT(2)=" Start Date: "_$$DAT1^IBOUTL(IBTSBDT)
+6 SET IBT(3)=" End Date: "_$$DAT1^IBOUTL(IBTSEDT)
+7 IF $DATA(IBMESS)
SET IBT(3.1)=IBMESS
+8 SET IBT(4)=""
+9 SET IBT(5)=" Total Rx fills checked: "_$GET(IBCNT)
+10 SET IBT(6)="Total NSC Rx fills Added: "_$GET(IBCNT1)
+11 SET IBT(7)=" Total SC Rx fills Added: "_$GET(IBCNT2)
+12 SET IBT(8)=""
+13 SET IBT(9)="*The fills added as SC require determination and editing to be billed"
+14 DO SEND
BULLQ QUIT
+1 ;
SEND SET XMDUZ="INTEGRATED BILLING PACKAGE"
SET XMTEXT="IBT("
+1 KILL XMY
SET XMN=0
+2 SET XMY(DUZ)=""
+3 DO ^XMD
+4 KILL X,Y,IBI,IBT,IBGRP,XMDUZ,XMTEXT,XMY,XMSUB
+5 QUIT
