IBCSC5C.m

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