source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC5A.m@ 1464

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

 ;;2.0;INTEGRATED BILLING;**27,52,106,51,160,137,245,309,347**;21-MAR-94;Build 24

 ;;Per VHA Directive 2004-038, this routine should not be modified.

 ;

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

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

 D SET(IBIFN,.IBRXA,"")

 D RXDISP^IBCSC5C(DFN,IBDT1,IBDT2,.IBPR,.IBPRO,.IBRXA,IBRXALL) I +$P($G(IBPRO),U,2) D NEWRX^IBCSC5C(+IBPRO) I +$G(IBLIST) D ADDNEW^IBCSC5C(IBIFN,IBLIST,.IBPR,.IBPRO) S DGRVRCAL=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 fill 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)) D  G:'IBPIFN E1

 . I 'IBPIFN W " ??" Q

 . W "  ... ADDED"

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

 ;

EXIT ;

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

 Q

 ;

ASKRX(IBRXAP,IBPRO) ;

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

 I +$G(IBIFN) S DIR("?")="The prescription number for the fill.  "_$$HTEXT^IBCSC5C,DIR("??")="^D HELP^IBCSC5A("_IBIFN_")"

 S DIR("A")="Select RX FILL",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 FILL "_$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 FILL 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,X,Y,DD,DO,DA,DIC,DLAYGO

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

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

 I Y>0 D

 . 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

 . S DGRVRCAL=1

ADDE Q IBX

 ;

EDIT(PIFN,REVIEN) ;

 N IBCHG,DIE,DR,DA,DIC,DIDEL

 S DIDEL=362.4,DIE="^IBA(362.4,"

 S DR=".01;.03;.04;.06;.07;.08;.09"

 S DA=PIFN D ^DIE

 I '$D(^IBA(362.4,PIFN,0)),$G(REVIEN) D  ; Deleted RX - delete related rev code/CPT code

 . I $P($G(^DGCR(399,IBIFN,"RC",REVIEN,0)),U,15) S DA(1)=IBIFN,DA=$P(^(0),U,15),DIK="^DGCR(399,"_DA(1)_",""CP""," D ^DIK

 . S DA=REVIEN,DA(1)=IBIFN,DIK="^DGCR(399,"_DA(1)_",""RC""," D ^DIK

 . S DGRVRCAL=1

 Q

 ;

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

 ;returns: RXARR(RX #, FILL DT)=RX IFN (362.4) ^ DRUG ^ DAYS SUPPLY ^ QTY ^ NDC # ^ Charge if known ^ ien of associated rev code multiple, if known ^ NDC FORMAT INDICATOR (1-4)

 ;         RXARR=BILL IFN ^ RX count

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

 ;

 D RCITEM(IFN,"IBRC",3)

 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),$P(RXARR($P(IBY,U),+$P(IBY,U,3)),U,6)=$$CHG^IBCF4(PIFN,3,.IBRC)

 . I $G(IFN) S $P(RXARR($P(IBY,U),+$P(IBY,U,3)),U,7)=$$FINDREV(IFN,3,PIFN)

 . S $P(RXARR($P(IBY,U),+$P(IBY,U,3)),U,8)=$P(IBY,U,9)

 ;

 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_"^"_$P(RXARR(IBX,IBY),U,7)

 Q

 ;

DISP(RXARR,RXARRP) ;screen display of existing fills 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,IBS,IBP,IBIFN

 W !!,?5,"-----------------  Existing Prescriptions on Bill  -----------------",!

 S IBIFN=+$G(RXARR)

 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 IBS=$$RXSTAT^IBCU1(+$P(RXARR(IBX,IBY),U,2),+$P($G(^IBA(362.4,+RXARR(IBX,IBY),0)),U,5),IBY)

 . D ZERO^IBRXUTL(+$P(RXARR(IBX,IBY),U,2))

 . S IBZ=$G(^TMP($J,"IBDRUG",+$P(RXARR(IBX,IBY),U,2),.01)),IBP=$$PRVNM(+RXARR(IBX,IBY))

 . K ^TMP($J,"IBDRUG")

 . W !,$J(IBI,2),")",?5,IBX,?19,$E(IBZ,1,25),?46,$$DATE^IBCSC5C(IBY),?56,$P(IBS,U,1),?61,$P(IBS,U,2),?69,$P(IBS,U,3)

 . S IBZ=$$RXDUP^IBCU3(IBX,IBY,IBIFN) I +IBZ W ?73,$P($G(^DGCR(399,+IBZ,0)),U,1)

 . S IBZ=$G(^DGCR(399,IBIFN,"RC",+$P(RXARR(IBX,IBY),U,7),0))

 . W !,?5,$E(IBP,1,25),?35,"(Rx Procedure ",$S($P(IBZ,U,15):"#"_$P(IBZ,U,15)_" "_$$CPTNM^IBCRBH1(IBIFN,4,$P(IBZ,U,15)),1:"Missing"),"  Rev Code ",$S(IBZ:"#"_+$P(RXARR(IBX,IBY),U,7)_" "_$P($G(^DGCR(399.2,+IBZ,0)),U),1:"Missing"),")"

 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,$P(IBX,U,4)) S IBRXAP=+IBPRO D SET(IFN,.IBRXA,.IBRXAP),DISP(.IBRXA,.IBRXAP)

 Q

BILL(IBIFN) ; return data on a bill 'patient ifn ^ from dt ^ to dt ^ true if add original rx'

 N IBX,IBY

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

 I '$$PERDIEM^IBCRU3(+$P(IBX,U,7),+$P(IBX,U,5),+$P(IBX,U,3)) S $P(IBY,U,4)=1

 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) S DIC(0)="VQ",DIC="^PSDRUG(" D DIC^PSSDI(50,"PS",.DIC,IBD,) I +Y<0  S IBD=0,DIC="^PSDRUG(",DIC(0)="AEQ" D DIC^PSSDI(50,"PS",.DIC,,) K DIC I +Y>0 S IBD=+Y

 Q IBD

 ;

RCITEM(IBIFN,ARRAY,TYPE) ; Pull off all item charges from RC multiple 

 ;  for item TYPE on bill IBIFN, return array ARRAY

 ; If type = "ALL", pull off all types

 ;Set up @ARRAY@(type,item reference,ct)=# units^unit charge

 ; If no pointer to an item, this was a manually entered charge and

 ;  will only 'associate' with the items found in the appropriate

 ;  item source file that are not referenced by an item in the revenue

 ;  code multiple in a sequential fashion (first unassociated 'RC' will

 ;  correlate to the first unassociated entry found for the bill in source file)

 N Z,Z0,Z1

 S Z=0

 F  S Z=$O(^DGCR(399,IBIFN,"RC",Z)) Q:'Z  S Z0=$G(^(Z,0)) I $S(TYPE="ALL":1,1:$P(Z0,U,10)=TYPE) I $P(Z0,U,10)'="" S Z1=$S($P(Z0,U,11)="":0,1:$P(Z0,U,11)),@ARRAY@($P(Z0,U,10),Z1,Z)=$P(Z0,U,3)_U_$P(Z0,U,2)

 Q

 ;

FINDREV(IBIFN,TYP,PTR) ; Finds the first revenue code that matches the

 ; same item type and item pointer

 ;

 N REVIEN,Z,Z0

 S Z=0

 F  S Z=$O(^DGCR(399,IBIFN,"RC",Z)) Q:'Z  S Z0=$G(^(Z,0)) I $P(Z0,U,10)=TYP,$P(Z0,U,11)=PTR S REVIEN=Z Q

 Q $G(REVIEN)

 ;

NDCNUM(IBNDC) ; Returns the format of the NDC # IBNDC, if possible

 N Z

 S Z=$TR(IBNDC,"-")

 Q $S(IBNDC?4N1"-"4N1"-"2N:1,IBNDC?5N1"-"3N1"-"2N:2,IBNDC?5N1"-"4N1"-"1N:3,IBNDC?5N1"-"4N1"-"2N!($L(Z)=11):4,IBNDC'="":1,1:"")

 ;

PRVNM(PIFN) ; return provider name for an rx, if one defined or null

 N IBX,IBPRV,IBRXIFN S IBPRV=""

 S IBRXIFN=$P($G(^IBA(362.4,+$G(PIFN),0)),U,5) I +IBRXIFN S IBX=$$FILE^IBRXUTL(IBRXIFN,4) I +IBX S IBPRV=$P($G(^VA(200,+IBX,0)),U,1)

 Q IBPRV