IBCSC5A.m

IBCSC5A	;ALB/ARH - ADD/ENTER PRESCRIPTION REFILLS ; 12/27/93

	;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94

	;;Per VHA Directive 10-93-142, this routine should not be modified.

	;

	;

EN	;add/edit prescription refills for a bill, IBIFN required

	S IBX=$$BILL(IBIFN) Q:'IBIFN  S DFN=+IBX,IBDT1=$P(IBX,U,2),IBDT2=$P(IBX,U,3),IBRXNEW=0

	D SET(IBIFN,.IBRXA,"") S IBRXOLD=+$P(IBRXA,U,2)

	D RXDISP^IBCSC5C(DFN,IBDT1,IBDT2,.IBPR,.IBPRO,.IBRXA) I +$P($G(IBPRO),U,2) D NEWRX^IBCSC5C(+IBPRO) I +$G(IBLIST) D ADDNEW^IBCSC5C(IBIFN,IBLIST,.IBPR,.IBPRO) S DGRVRCAL=1,IBRXNEW=1

	S IBRXAP=+$G(IBPRO) D SET(IBIFN,.IBRXA,.IBRXAP),DISP(.IBRXA,.IBRXAP)

E1	S IBPIFN=0,IBRX=$$ASKRX(.IBRXAP,.IBPRO) G:IBRX="" EXIT S IBDT=$P(IBRX,U,2),IBRX=$P(IBRX,U,1),DGRVRCAL=1

	I 'IBDT S IBDT=$O(IBRXA(IBRX,0)) S:'IBDT IBDT=$O(IBPR(IBRX,0)) S IBDT=$$ASKDT(IBDT1,IBDT2,IBDT) G:'IBDT E1

	I +$$RXDUP^IBCU3(IBRX,IBDT,IBIFN,1),'$D(IBRXA(IBRX,IBDT)) G E1

	I '$D(IBPR(IBRX,IBDT)) W !,"This rx refill does not exist in Pharmacy for this patient!",!

	S IBPIFN=$G(IBRXA(IBRX,IBDT)),IBDRG=$P(IBPIFN,U,2)

	I 'IBPIFN S IBX=$G(IBPR(IBRX,IBDT)),IBPIFN=$$ADD(IBRX,IBIFN,IBDT,$P(IBX,U,3),$P(IBX,U,1),$P(IBX,U,4,6)) S:+IBPIFN IBRXNEW=1 W:+IBPIFN "  ... ADDED" I 'IBPIFN W " ??" G E1

	D EDIT(+IBPIFN) S IBRXAP=+$G(IBPRO) D SET(IBIFN,.IBRXA,.IBRXAP) G E1

	;

EXIT	I 'IBRXOLD,+IBRXNEW D DEFAULT^IBCSC5C(IBIFN)

	K IBPIFN,IBRX,IBDRG,IBX,IBDT1,IBDT2,IBRXA,IBPR,IBDT,IBRXNEW,IBRXOLD,IBLIST,IBPRO,IBRXAP

	Q

	;

ASKRX(IBRXAP,IBPRO)	;

	N X,Y,IBY,IBX W ! S IBX=""

	I +$G(IBIFN) S DIR("?")="The prescription number for the refill",DIR("??")="^D HELP^IBCSC5A("_IBIFN_")"

	S DIR("A")="Select RX REFILL",DIR(0)="FO^1:11^K:X'?.UN X" D ^DIR I $D(DIRUT)!(Y'?.AN) S Y="" K DIR,DIRUT G ARX1E

	S IBX=Y I $D(IBRXAP)<10,$D(IBPRO)<10 G ARX1E

	;

	S IBY=$G(IBRXAP(IBX)) S:IBY="" IBY=$G(IBPRO(IBX)) I IBY="" G ARX1E

	W ! S DIR(0)="YO",DIR("A")="ADD/EDIT RX REFILL "_$P(IBY,U,1)_" FOR "_$$FMTE^XLFDT($P(IBY,U,2))_" CORRECT",DIR("B")="YES"

	D ^DIR K DIR I Y=1,'$D(DIRUT) S IBX=IBY

ARX1E	Q IBX

	;

ASKDT(IBDT1,IBDT2,IBDT)	;

	S DIR("A")="Select RX REFILL DATE",DIR(0)="DO^"_IBDT1_":"_IBDT2_":EX",DIR("B")=$$FMTE^XLFDT(IBDT) D ^DIR K DIR,DTOUT,DIRUT

	Q $S(Y?7N:Y,1:0)

	;

ADD(RX,IFN,IBDT,DRUG,PIFN,OTHER)	;

	N IBX S IBX=0 S DRUG=$$DRUG($G(DRUG)) G:'DRUG ADDE

	S DIC="^IBA(362.4,",DIC(0)="AQL",X=RX K DA,DO D FILE^DICN K DA,DO,X

	I Y>0 S DIE=DIC,(IBX,DA)=+Y,DR=".02////"_IFN_";.03////"_IBDT_";.04////"_DRUG_";.05////"_+PIFN_";.06////"_$P(OTHER,U,1)_";.07////"_$P(OTHER,U,2)_";.08////"_$P(OTHER,U,3) D ^DIE K DIE,DIC,DA,DR

ADDE	Q IBX

	;

EDIT(PIFN)	;

	S DIDEL=362.4,DIE="^IBA(362.4,",DR=".01;.03;.04;.06;.07;.08",DA=PIFN D ^DIE K DIE,DR,DA,DIC,DIDEL

	Q

	;

SET(IFN,RXARR,RXARRP)	;setup array of all rx refills for bill, array name should be passed by reference

	;returns: RXARR(RX #, REFILL DT)=RX IFN (362.4) ^ DRUG ^ DAYS SUPPLY ^ QTY ^ NDC #,    RXARR=BILL IFN ^ RX count

	N CNT,IBX,IBY,IBZ,PIFN,IBC,IBCNT S IBCNT=+$G(RXARRP),IBC="AIFN"_$G(IFN) K RXARR,RXARRP

	S (CNT,IBX)=0 F  S IBX=$O(^IBA(362.4,IBC,IBX)) Q:IBX=""  S PIFN=0 F  S PIFN=$O(^IBA(362.4,IBC,IBX,PIFN)) Q:'PIFN  D

	. S IBY=$G(^IBA(362.4,PIFN,0)) Q:IBY=""  S CNT=CNT+1,RXARR($P(IBY,U,1),+$P(IBY,U,3))=PIFN_U_$P(IBY,U,4)_U_$P(IBY,U,6,8)

	S RXARR=$G(IFN)_"^"_CNT

	S IBX=0 F  S IBX=$O(RXARR(IBX)) Q:IBX=""  S IBY=0 F  S IBY=$O(RXARR(IBX,IBY)) Q:'IBY  S IBCNT=IBCNT+1,RXARRP(IBCNT)=IBX_"^"_IBY

	Q

	;

DISP(RXARR,RXARRP)	;screen display of existing refills for a bill,

	;input should be print order array returned by SET^IBCSC5A: RXARR(RX,DT)=RX IFN (362.4) ^ DRUG, passed by reference

	N IBX,IBY,IBZ

	W !!,?5,"-----------------  Existing Rx Refills for Bill  -----------------",!

	S IBI=0 F  S IBI=$O(RXARRP(IBI)) Q:IBI=""  S IBX=$P(RXARRP(IBI),U,1),IBY=$P(RXARRP(IBI),U,2) I $D(RXARR(IBX,IBY)) D

	. S IBZ=$P($G(^PSDRUG(+$P(RXARR(IBX,IBY),U,2),0)),U,1)

	. W !,$J(IBI,2),")",?7,IBX,?20,$E(IBZ,1,38),?60,$$FMTE^XLFDT(IBY)

	W !

	Q

	;

HELP(IFN)	;called for help from rx enter to display existing rx, displays rx' from 52 and 399

	I +$G(IFN) N IBX,IBRXA S IBX=$$BILL(IFN) I +IBX D SET(IFN,.IBRXA,""),RXDISP^IBCSC5C($P(IBX,U,1),$P(IBX,U,2),$P(IBX,U,3),.IBPR,.IBPRO,.IBRXA) S IBRXAP=+IBPRO D SET(IFN,.IBRXA,.IBRXAP),DISP(.IBRXA,.IBRXAP)

	Q

	;

BILL(IBIFN)	; display all existing prescription refills (52) for a patient and date range

	; (call is a short cut to calling rxdisp if have bill number)

	N IBX,IBY S IBX=$G(^DGCR(399,+$G(IBIFN),0)),IBY=$P(IBX,U,2)

	S IBX=$G(^DGCR(399,+IBIFN,"U")),$P(IBY,U,2)=+IBX,$P(IBY,U,3)=+$P(IBX,U,2)

	Q IBY

	;

DRUG(IBD)	; get drug

	N X,Y S IBD=+$G(IBD) I '$D(^PSDRUG(IBD,0)) S IBD=0,DIC="^PSDRUG(",DIC(0)="AEQ" D ^DIC K DIC I +Y>0 S IBD=+Y

	Q IBD

IBCSC5A   ;ALB/ARH - ADD/ENTER PRESCRIPTION REFILLS ; 12/27/93

 +1       ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94

 +2       ;;Per VHA Directive 10-93-142, this routine should not be modified.

 +3       ;

 +4       ;

EN        ;add/edit prescription refills for a bill, IBIFN required

 +1        SET IBX=$$BILL(IBIFN)

           IF 'IBIFN

               QUIT 

           SET DFN=+IBX

           SET IBDT1=$PIECE(IBX,U,2)

           SET IBDT2=$PIECE(IBX,U,3)

           SET IBRXNEW=0

 +2        DO SET(IBIFN,.IBRXA,"")

           SET IBRXOLD=+$PIECE(IBRXA,U,2)

 +3        DO RXDISP^IBCSC5C(DFN,IBDT1,IBDT2,.IBPR,.IBPRO,.IBRXA)

           IF +$PIECE($GET(IBPRO),U,2)

               DO NEWRX^IBCSC5C(+IBPRO)

               IF +$GET(IBLIST)

                   DO ADDNEW^IBCSC5C(IBIFN,IBLIST,.IBPR,.IBPRO)

                   SET DGRVRCAL=1

                   SET IBRXNEW=1

 +4        SET IBRXAP=+$GET(IBPRO)

           DO SET(IBIFN,.IBRXA,.IBRXAP)

           DO DISP(.IBRXA,.IBRXAP)

E1         SET IBPIFN=0

           SET IBRX=$$ASKRX(.IBRXAP,.IBPRO)

           IF IBRX=""

               GOTO EXIT

           SET IBDT=$PIECE(IBRX,U,2)

           SET IBRX=$PIECE(IBRX,U,1)

           SET DGRVRCAL=1

 +1        IF 'IBDT

               SET IBDT=$ORDER(IBRXA(IBRX,0))

               IF 'IBDT

                   SET IBDT=$ORDER(IBPR(IBRX,0))

               SET IBDT=$$ASKDT(IBDT1,IBDT2,IBDT)

               IF 'IBDT

                   GOTO E1

 +2        IF +$$RXDUP^IBCU3(IBRX,IBDT,IBIFN,1)

               IF '$DATA(IBRXA(IBRX,IBDT))

                   GOTO E1

 +3        IF '$DATA(IBPR(IBRX,IBDT))

               WRITE !,"This rx refill does not exist in Pharmacy for this patient!",!

 +4        SET IBPIFN=$GET(IBRXA(IBRX,IBDT))

           SET IBDRG=$PIECE(IBPIFN,U,2)

 +5        IF 'IBPIFN

               SET IBX=$GET(IBPR(IBRX,IBDT))

               SET IBPIFN=$$ADD(IBRX,IBIFN,IBDT,$PIECE(IBX,U,3),$PIECE(IBX,U,1),$PIECE(IBX,U,4,6))

               IF +IBPIFN

                   SET IBRXNEW=1

               IF +IBPIFN

                   WRITE "  ... ADDED"

               IF 'IBPIFN

                   WRITE " ??"

                   GOTO E1

 +6        DO EDIT(+IBPIFN)

           SET IBRXAP=+$GET(IBPRO)

           DO SET(IBIFN,.IBRXA,.IBRXAP)

           GOTO E1

 +7       ;

EXIT       IF 'IBRXOLD

               IF +IBRXNEW

                   DO DEFAULT^IBCSC5C(IBIFN)

 +1        KILL IBPIFN,IBRX,IBDRG,IBX,IBDT1,IBDT2,IBRXA,IBPR,IBDT,IBRXNEW,IBRXOLD,IBLIST,IBPRO,IBRXAP

 +2        QUIT 

 +3       ;

ASKRX(IBRXAP,IBPRO) ;

 +1        NEW X,Y,IBY,IBX

           WRITE !

           SET IBX=""

 +2        IF +$GET(IBIFN)

               SET DIR("?")="The prescription number for the refill"

               SET DIR("??")="^D HELP^IBCSC5A("_IBIFN_")"

 +3        SET DIR("A")="Select RX REFILL"

           SET DIR(0)="FO^1:11^K:X'?.UN X"

           DO ^DIR

           IF $DATA(DIRUT)!(Y'?.AN)

               SET Y=""

               KILL DIR,DIRUT

               GOTO ARX1E

 +4        SET IBX=Y

           IF $DATA(IBRXAP)<10

               IF $DATA(IBPRO)<10

                   GOTO ARX1E

 +5       ;

 +6        SET IBY=$GET(IBRXAP(IBX))

           IF IBY=""

               SET IBY=$GET(IBPRO(IBX))

           IF IBY=""

               GOTO ARX1E

 +7        WRITE !

           SET DIR(0)="YO"

           SET DIR("A")="ADD/EDIT RX REFILL "_$PIECE(IBY,U,1)_" FOR "_$$FMTE^XLFDT($PIECE(IBY,U,2))_" CORRECT"

           SET DIR("B")="YES"

 +8        DO ^DIR

           KILL DIR

           IF Y=1

               IF '$DATA(DIRUT)

                   SET IBX=IBY

ARX1E      QUIT IBX

 +1       ;

ASKDT(IBDT1,IBDT2,IBDT) ;

 +1        SET DIR("A")="Select RX REFILL DATE"

           SET DIR(0)="DO^"_IBDT1_":"_IBDT2_":EX"

           SET DIR("B")=$$FMTE^XLFDT(IBDT)

           DO ^DIR

           KILL DIR,DTOUT,DIRUT

 +2        QUIT $SELECT(Y?7N:Y,1:0)

 +3       ;

ADD(RX,IFN,IBDT,DRUG,PIFN,OTHER) ;

 +1        NEW IBX

           SET IBX=0

           SET DRUG=$$DRUG($GET(DRUG))

           IF 'DRUG

               GOTO ADDE

 +2        SET DIC="^IBA(362.4,"

           SET DIC(0)="AQL"

           SET X=RX

           KILL DA,DO

           DO FILE^DICN

           KILL DA,DO,X

 +3        IF Y>0

               SET DIE=DIC

               SET (IBX,DA)=+Y

               SET DR=".02////"_IFN_";.03////"_IBDT_";.04////"_DRUG_";.05////"_+PIFN_";.06////"_$PIECE(OTHER,U,1)_";.07////"_$PIECE(OTHER,U,2)_";.08////"_$PIECE(OTHER,U,3)

               DO ^DIE

               KILL DIE,DIC,DA,DR

ADDE       QUIT IBX

 +1       ;

EDIT(PIFN) ;

 +1        SET DIDEL=362.4

           SET DIE="^IBA(362.4,"

           SET DR=".01;.03;.04;.06;.07;.08"

           SET DA=PIFN

           DO ^DIE

           KILL DIE,DR,DA,DIC,DIDEL

 +2        QUIT 

 +3       ;

SET(IFN,RXARR,RXARRP) ;setup array of all rx refills for bill, array name should be passed by reference

 +1       ;returns: RXARR(RX #, REFILL DT)=RX IFN (362.4) ^ DRUG ^ DAYS SUPPLY ^ QTY ^ NDC #,    RXARR=BILL IFN ^ RX count

 +2        NEW CNT,IBX,IBY,IBZ,PIFN,IBC,IBCNT

           SET IBCNT=+$GET(RXARRP)

           SET IBC="AIFN"_$GET(IFN)

           KILL RXARR,RXARRP

 +3        SET (CNT,IBX)=0

           FOR 

               SET IBX=$ORDER(^IBA(362.4,IBC,IBX))

               IF IBX=""

                   QUIT 

               SET PIFN=0

               FOR 

                   SET PIFN=$ORDER(^IBA(362.4,IBC,IBX,PIFN))

                   IF 'PIFN

                       QUIT 

                   Begin DoDot:1

 +4                    SET IBY=$GET(^IBA(362.4,PIFN,0))

                       IF IBY=""

                           QUIT 

                       SET CNT=CNT+1

                       SET RXARR($PIECE(IBY,U,1),+$PIECE(IBY,U,3))=PIFN_U_$PIECE(IBY,U,4)_U_$PIECE(IBY,U,6,8)

                   End DoDot:1

 +5        SET RXARR=$GET(IFN)_"^"_CNT

 +6        SET IBX=0

           FOR 

               SET IBX=$ORDER(RXARR(IBX))

               IF IBX=""

                   QUIT 

               SET IBY=0

               FOR 

                   SET IBY=$ORDER(RXARR(IBX,IBY))

                   IF 'IBY

                       QUIT 

                   SET IBCNT=IBCNT+1

                   SET RXARRP(IBCNT)=IBX_"^"_IBY

 +7        QUIT 

 +8       ;

DISP(RXARR,RXARRP) ;screen display of existing refills for a bill,

 +1       ;input should be print order array returned by SET^IBCSC5A: RXARR(RX,DT)=RX IFN (362.4) ^ DRUG, passed by reference

 +2        NEW IBX,IBY,IBZ

 +3        WRITE !!,?5,"-----------------  Existing Rx Refills for Bill  -----------------",!

 +4        SET IBI=0

           FOR 

               SET IBI=$ORDER(RXARRP(IBI))

               IF IBI=""

                   QUIT 

               SET IBX=$PIECE(RXARRP(IBI),U,1)

               SET IBY=$PIECE(RXARRP(IBI),U,2)

               IF $DATA(RXARR(IBX,IBY))

                   Begin DoDot:1

 +5                    SET IBZ=$PIECE($GET(^PSDRUG(+$PIECE(RXARR(IBX,IBY),U,2),0)),U,1)

 +6                    WRITE !,$JUSTIFY(IBI,2),")",?7,IBX,?20,$EXTRACT(IBZ,1,38),?60,$$FMTE^XLFDT(IBY)

                   End DoDot:1

 +7        WRITE !

 +8        QUIT 

 +9       ;

HELP(IFN) ;called for help from rx enter to display existing rx, displays rx' from 52 and 399

 +1        IF +$GET(IFN)

               NEW IBX,IBRXA

               SET IBX=$$BILL(IFN)

               IF +IBX

                   DO SET(IFN,.IBRXA,"")

                   DO RXDISP^IBCSC5C($PIECE(IBX,U,1),$PIECE(IBX,U,2),$PIECE(IBX,U,3),.IBPR,.IBPRO,.IBRXA)

                   SET IBRXAP=+IBPRO

                   DO SET(IFN,.IBRXA,.IBRXAP)

                   DO DISP(.IBRXA,.IBRXAP)

 +2        QUIT 

 +3       ;

BILL(IBIFN) ; display all existing prescription refills (52) for a patient and date range

 +1       ; (call is a short cut to calling rxdisp if have bill number)

 +2        NEW IBX,IBY

           SET IBX=$GET(^DGCR(399,+$GET(IBIFN),0))

           SET IBY=$PIECE(IBX,U,2)

 +3        SET IBX=$GET(^DGCR(399,+IBIFN,"U"))

           SET $PIECE(IBY,U,2)=+IBX

           SET $PIECE(IBY,U,3)=+$PIECE(IBX,U,2)

 +4        QUIT IBY

 +5       ;

DRUG(IBD) ; get drug

 +1        NEW X,Y

           SET IBD=+$GET(IBD)

           IF '$DATA(^PSDRUG(IBD,0))

               SET IBD=0

               SET DIC="^PSDRUG("

               SET DIC(0)="AEQ"

               DO ^DIC

               KILL DIC

               IF +Y>0

                   SET IBD=+Y

 +2        QUIT IBD