IBCSC5C ;ALB/ARH - ADD/EDIT RX REFILLS (CONTINUED) ; 3/4/94
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
;
DEFAULT(IFN) ; add default DX and CPT to a Rx bill
N IBX,IBPAR1,IBDX,IBCPT,IBDT,IBBIL S IBPAR1=$G(^IBE(350.9,1,1)),IBDX=$P(IBPAR1,U,29),IBCPT=$P(IBPAR1,U,30) I 'IBDX,'IBCPT Q
S IBBIL=$G(^DGCR(399,+$G(IFN),0)) Q:IBBIL=""
S IBX=$O(^IBA(362.4,"C",IFN,0)) Q:'IBX S IBDT=$P($G(^IBA(362.4,+IBX,0)),U,3) Q:'IBDT
I +IBDX,'$D(^IBA(362.3,"AIFN"_IFN,+IBDX)) S DIC="^IBA(362.3,",DIC(0)="L",DIC("DR")=".02////"_IFN,X=IBDX K DD,DO D FILE^DICN K DIC,DA,DR,DD,DO
I +IBCPT,'$D(^DGCR(399,IFN,"CP","B",IBCPT_";ICPT(")) D
. I $P(IBBIL,U,9)="" S DIE="^DGCR(399,",DA=IFN,DR=".09////4" D ^DIE K DIE,DIC,DA,DR
. I '$D(^DGCR(399,IFN,"CP",0)) S ^DGCR(399,IFN,"CP",0)="^399.0304AVI^"
. S DIC="^DGCR(399,"_IFN_",""CP"",",DIC(0)="L",DA(1)=IFN,X=IBCPT_";ICPT(",DIC("DR")="1////"_IBDT K DD,DO D FILE^DICN K DIC,DA,DD,DO,DR
Q
;
RXDISP(DFN,DT1,DT2,ARRAY,POARR,RXARR) ; display all re refills for a patient and date range
;RXARR (as defined by SET^IBCSC5A) passed by ref. only to check if rx-refill is on the bill, not necessary not changed
;returns: ARRAY(RX #, REFILL DT) = RX IFN (52) ^ REFILL IFN ^ DRUG ^ DAYS SUPPLY ^ QTY ^ NDC, pass by reference if desired
; POARR(CNT)=RX # ^ REFILL DT
N PIFN,RIFN,IBX,IBY,DTE,DTR,RX,IBCNT K ARRAY,POARR S POARR=0
S IBCNT=0,DT1=$G(DT1)-.0001,DT2=$G(DT2) S:'DT2 DT2=9999999 Q:'$G(DFN)
;^PS(55,DFN,"P","A",EXPIRATION DATE, RX) is the best xref available for finding patient refills in a date range
S DTE=DT1 F S DTE=$O(^PS(55,DFN,"P","A",DTE)) Q:'DTE D
. S PIFN=0 F S PIFN=$O(^PS(55,DFN,"P","A",DTE,PIFN)) Q:'PIFN D
.. S DTR=DT1 F S DTR=$O(^PSRX(PIFN,1,"B",DTR)) Q:'DTR!(DTR>DT2) D
... S RIFN=0 F S RIFN=$O(^PSRX(PIFN,1,"B",DTR,RIFN)) Q:'RIFN D
.... S IBX=$G(^PSRX(PIFN,0)),IBY=$G(^PSRX(PIFN,1,RIFN,0)) Q:IBY=""
.... S ARRAY($P(IBX,U,1),+IBY)=PIFN_U_RIFN_U_$P(IBX,U,6)_U_$P(IBX,U,8)_U_$P(IBY,U,4)_U_$P($G(^PSDRUG(+$P(IBX,U,6),2)),U,4)
S IBX="" F S IBX=$O(ARRAY(IBX)) Q:IBX="" S IBY=0 F S IBY=$O(ARRAY(IBX,IBY)) Q:'IBY D
. S IBCNT=IBCNT+1,POARR(IBCNT)=$P(IBX,U,1)_"^"_+IBY,POARR=IBCNT
;
W @IOF,?32,"PRESCRIPTION REFILLS",!,"==============================================================================",!
S IBX=+POARR,IBCNT=0 F S IBCNT=$O(POARR(IBCNT)) Q:IBCNT="" S RX=$P(POARR(IBCNT),U,1),DTR=$P(POARR(IBCNT),U,2) I RX'="",DTR'="" D
. S IBY="" I $D(RXARR(RX,+DTR)) S IBX=IBX-1,IBY="*"
. W !,$J(IBCNT,2),")",?5,IBY,?7,RX,?20,$P($G(^PSDRUG(+$P(ARRAY(RX,DTR),U,3),0)),U,1),?60,$$FMTE^XLFDT(+DTR)
S $P(POARR,U,2)=IBX
Q
;
NEWRX(IBX) ;
Q:'$G(IBX) N X,Y K IBLIST W !
NEWRX1 S DIR("?")="Enter the number preceding the RX Refills you want added to the bill."
S DIR("A")="SELECT NEW RX REFILLS TO ADD THE THE BILL"
S DIR(0)="LO^1:"_+IBX D ^DIR K DIR G:'Y!$D(DIRUT) NEWRXE
S IBLIST=Y
;
S DIR("A")="YOU HAVE SELECTED "_IBLIST_" TO BE ADDED TO THE BILL IS THIS CORRECT",DIR("B")="YES"
S DIR(0)="YO" D ^DIR K DIR I $D(DIRUT) K IBLIST G NEWRXE
I 'Y G NEWRX1
NEWRXE Q
;
ADDNEW(IBIFN,LIST,IBPR,IBPRO) ;
Q:'LIST N IBI,IBX,IBRX,IBDT,IBQ,IBY,IBPIFN,IBZ
F IBI=1:1 S IBX=$P(LIST,",",IBI) Q:'IBX I $D(IBPRO(IBX)) D
. S IBRX=$P(IBPRO(IBX),U,1),IBDT=$P(IBPRO(IBX),U,2) Q:IBRX=""
. S IBQ=0,IBY=$G(IBPR(IBRX,+IBDT)) Q:'IBY
. S IBPIFN=0 F S IBPIFN=$O(^IBA(362.4,"AIFN"_IBIFN,IBRX,IBPIFN)) Q:'IBPIFN I $P($G(^IBA(362.4,IBPIFN,0)),U,3)=IBDT S IBQ=1 Q
. I 'IBQ S IBZ=$G(IBPR(IBRX,IBDT)) I $$ADD^IBCSC5A(IBRX,IBIFN,IBDT,$P(IBZ,U,3),$P(IBZ,U,1),$P(IBZ,U,4,6)) W "."
Q
IBCSC5C ;ALB/ARH - ADD/EDIT RX REFILLS (CONTINUED) ; 3/4/94
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ;
DEFAULT(IFN) ; add default DX and CPT to a Rx bill
+1 NEW IBX,IBPAR1,IBDX,IBCPT,IBDT,IBBIL
SET IBPAR1=$GET(^IBE(350.9,1,1))
SET IBDX=$PIECE(IBPAR1,U,29)
SET IBCPT=$PIECE(IBPAR1,U,30)
IF 'IBDX
IF 'IBCPT
QUIT
+2 SET IBBIL=$GET(^DGCR(399,+$GET(IFN),0))
IF IBBIL=""
QUIT
+3 SET IBX=$ORDER(^IBA(362.4,"C",IFN,0))
IF 'IBX
QUIT
SET IBDT=$PIECE($GET(^IBA(362.4,+IBX,0)),U,3)
IF 'IBDT
QUIT
+4 IF +IBDX
IF '$DATA(^IBA(362.3,"AIFN"_IFN,+IBDX))
SET DIC="^IBA(362.3,"
SET DIC(0)="L"
SET DIC("DR")=".02////"_IFN
SET X=IBDX
KILL DD,DO
DO FILE^DICN
KILL DIC,DA,DR,DD,DO
+5 IF +IBCPT
IF '$DATA(^DGCR(399,IFN,"CP","B",IBCPT_";ICPT("))
Begin DoDot:1
+6 IF $PIECE(IBBIL,U,9)=""
SET DIE="^DGCR(399,"
SET DA=IFN
SET DR=".09////4"
DO ^DIE
KILL DIE,DIC,DA,DR
+7 IF '$DATA(^DGCR(399,IFN,"CP",0))
SET ^DGCR(399,IFN,"CP",0)="^399.0304AVI^"
+8 SET DIC="^DGCR(399,"_IFN_",""CP"","
SET DIC(0)="L"
SET DA(1)=IFN
SET X=IBCPT_";ICPT("
SET DIC("DR")="1////"_IBDT
KILL DD,DO
DO FILE^DICN
KILL DIC,DA,DD,DO,DR
End DoDot:1
+9 QUIT
+10 ;
RXDISP(DFN,DT1,DT2,ARRAY,POARR,RXARR) ; display all re refills for a patient and date range
+1 ;RXARR (as defined by SET^IBCSC5A) passed by ref. only to check if rx-refill is on the bill, not necessary not changed
+2 ;returns: ARRAY(RX #, REFILL DT) = RX IFN (52) ^ REFILL IFN ^ DRUG ^ DAYS SUPPLY ^ QTY ^ NDC, pass by reference if desired
+3 ; POARR(CNT)=RX # ^ REFILL DT
+4 NEW PIFN,RIFN,IBX,IBY,DTE,DTR,RX,IBCNT
KILL ARRAY,POARR
SET POARR=0
+5 SET IBCNT=0
SET DT1=$GET(DT1)-.0001
SET DT2=$GET(DT2)
IF 'DT2
SET DT2=9999999
IF '$GET(DFN)
QUIT
+6 ;^PS(55,DFN,"P","A",EXPIRATION DATE, RX) is the best xref available for finding patient refills in a date range
+7 SET DTE=DT1
FOR
SET DTE=$ORDER(^PS(55,DFN,"P","A",DTE))
IF 'DTE
QUIT
Begin DoDot:1
+8 SET PIFN=0
FOR
SET PIFN=$ORDER(^PS(55,DFN,"P","A",DTE,PIFN))
IF 'PIFN
QUIT
Begin DoDot:2
+9 SET DTR=DT1
FOR
SET DTR=$ORDER(^PSRX(PIFN,1,"B",DTR))
IF 'DTR!(DTR>DT2)
QUIT
Begin DoDot:3
+10 SET RIFN=0
FOR
SET RIFN=$ORDER(^PSRX(PIFN,1,"B",DTR,RIFN))
IF 'RIFN
QUIT
Begin DoDot:4
+11 SET IBX=$GET(^PSRX(PIFN,0))
SET IBY=$GET(^PSRX(PIFN,1,RIFN,0))
IF IBY=""
QUIT
+12 SET ARRAY($PIECE(IBX,U,1),+IBY)=PIFN_U_RIFN_U_$PIECE(IBX,U,6)_U_$PIECE(IBX,U,8)_U_$PIECE(IBY,U,4)_U_$PIECE($GET(^PSDRUG(+$PIECE(IBX,U,6),2)),U,4)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+13 SET IBX=""
FOR
SET IBX=$ORDER(ARRAY(IBX))
IF IBX=""
QUIT
SET IBY=0
FOR
SET IBY=$ORDER(ARRAY(IBX,IBY))
IF 'IBY
QUIT
Begin DoDot:1
+14 SET IBCNT=IBCNT+1
SET POARR(IBCNT)=$PIECE(IBX,U,1)_"^"_+IBY
SET POARR=IBCNT
End DoDot:1
+15 ;
+16 WRITE @IOF,?32,"PRESCRIPTION REFILLS",!,"==============================================================================",!
+17 SET IBX=+POARR
SET IBCNT=0
FOR
SET IBCNT=$ORDER(POARR(IBCNT))
IF IBCNT=""
QUIT
SET RX=$PIECE(POARR(IBCNT),U,1)
SET DTR=$PIECE(POARR(IBCNT),U,2)
IF RX'=""
IF DTR'=""
Begin DoDot:1
+18 SET IBY=""
IF $DATA(RXARR(RX,+DTR))
SET IBX=IBX-1
SET IBY="*"
+19 WRITE !,$JUSTIFY(IBCNT,2),")",?5,IBY,?7,RX,?20,$PIECE($GET(^PSDRUG(+$PIECE(ARRAY(RX,DTR),U,3),0)),U,1),?60,$$FMTE^XLFDT(+DTR)
End DoDot:1
+20 SET $PIECE(POARR,U,2)=IBX
+21 QUIT
+22 ;
NEWRX(IBX) ;
+1 IF '$GET(IBX)
QUIT
NEW X,Y
KILL IBLIST
WRITE !
NEWRX1 SET DIR("?")="Enter the number preceding the RX Refills you want added to the bill."
+1 SET DIR("A")="SELECT NEW RX REFILLS TO ADD THE THE BILL"
+2 SET DIR(0)="LO^1:"_+IBX
DO ^DIR
KILL DIR
IF 'Y!$DATA(DIRUT)
GOTO NEWRXE
+3 SET IBLIST=Y
+4 ;
+5 SET DIR("A")="YOU HAVE SELECTED "_IBLIST_" TO BE ADDED TO THE BILL IS THIS CORRECT"
SET DIR("B")="YES"
+6 SET DIR(0)="YO"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
KILL IBLIST
GOTO NEWRXE
+7 IF 'Y
GOTO NEWRX1
NEWRXE QUIT
+1 ;
ADDNEW(IBIFN,LIST,IBPR,IBPRO) ;
+1 IF 'LIST
QUIT
NEW IBI,IBX,IBRX,IBDT,IBQ,IBY,IBPIFN,IBZ
+2 FOR IBI=1:1
SET IBX=$PIECE(LIST,",",IBI)
IF 'IBX
QUIT
IF $DATA(IBPRO(IBX))
Begin DoDot:1
+3 SET IBRX=$PIECE(IBPRO(IBX),U,1)
SET IBDT=$PIECE(IBPRO(IBX),U,2)
IF IBRX=""
QUIT
+4 SET IBQ=0
SET IBY=$GET(IBPR(IBRX,+IBDT))
IF 'IBY
QUIT
+5 SET IBPIFN=0
FOR
SET IBPIFN=$ORDER(^IBA(362.4,"AIFN"_IBIFN,IBRX,IBPIFN))
IF 'IBPIFN
QUIT
IF $PIECE($GET(^IBA(362.4,IBPIFN,0)),U,3)=IBDT
SET IBQ=1
QUIT
+6 IF 'IBQ
SET IBZ=$GET(IBPR(IBRX,IBDT))
IF $$ADD^IBCSC5A(IBRX,IBIFN,IBDT,$PIECE(IBZ,U,3),$PIECE(IBZ,U,1),$PIECE(IBZ,U,4,6))
WRITE "."
End DoDot:1
+7 QUIT
