Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBCSC5A

IBCSC5A.m

Go to the documentation of this file.
  1. IBCSC5A ;ALB/ARH - ADD/ENTER PRESCRIPTION FILLS ;12/27/93
  1. ;;2.0;INTEGRATED BILLING;**27,52,106,51,160,137,245,309,347,405,432**;21-MAR-94;Build 192
  1. ;;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;
  1. EN ;add/edit prescription fills for a bill, IBIFN required
  1. S IBX=$$BILL(IBIFN) Q:'IBIFN S DFN=+IBX,IBDT1=$P(IBX,U,2),IBDT2=$P(IBX,U,3),IBRXALL=$P(IBX,U,4)
  1. D SET(IBIFN,.IBRXA,"")
  1. 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
  1. S IBRXAP=+$G(IBPRO) D SET(IBIFN,.IBRXA,.IBRXAP),DISP(.IBRXA,.IBRXAP)
  1. E1 S IBPIFN=0,IBRX=$$ASKRX(.IBRXAP,.IBPRO) G:IBRX="" EXIT S IBDT=$P(IBRX,U,2),IBRX=$P(IBRX,U,1),DGRVRCAL=1
  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
  1. I +$$RXDUP^IBCU3(IBRX,IBDT,IBIFN,1),'$D(IBRXA(IBRX,IBDT)) G E1
  1. I '$D(IBPR(IBRX,IBDT)) W !,"This rx fill does not exist in Pharmacy for this patient!",!
  1. S IBPIFN=$G(IBRXA(IBRX,IBDT)),IBDRG=$P(IBPIFN,U,2)
  1. 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),$P(IBX,U,2)) D G:'IBPIFN E1
  1. . I 'IBPIFN W " ??" Q
  1. . W " ... ADDED"
  1. D EDIT(+IBPIFN,$P(IBPIFN,U,7)) S IBRXAP=+$G(IBPRO) D SET(IBIFN,.IBRXA,.IBRXAP) G E1
  1. ;
  1. EXIT ;
  1. K IBPIFN,IBRX,IBDRG,IBX,IBDT1,IBDT2,IBRXA,IBPR,IBDT,IBLIST,IBPRO,IBRXAP,IBRXALL
  1. Q
  1. ;
  1. ASKRX(IBRXAP,IBPRO) ;
  1. N X,Y,IBY,IBX W ! S IBX=""
  1. I +$G(IBIFN) S DIR("?")="The prescription number for the fill. "_$$HTEXT^IBCSC5C,DIR("??")="^D HELP^IBCSC5A("_IBIFN_")"
  1. 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
  1. S IBX=Y I $D(IBRXAP)<10,$D(IBPRO)<10 G ARX1E
  1. ;
  1. S IBY=$G(IBRXAP(IBX)) S:IBY="" IBY=$G(IBPRO(IBX)) I IBY="" G ARX1E
  1. 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"
  1. D ^DIR K DIR I Y=1,'$D(DIRUT) S IBX=IBY
  1. ARX1E Q IBX
  1. ;
  1. ASKDT(IBDT1,IBDT2,IBDT) ;
  1. S DIR("A")="Select RX FILL DATE",DIR(0)="DO^"_IBDT1_":"_IBDT2_":EX",DIR("B")=$$FMTE^XLFDT(IBDT) D ^DIR K DIR,DTOUT,DIRUT
  1. Q $S(Y?7N:Y,1:0)
  1. ;
  1. ADD(RX,IFN,IBDT,DRUG,PIFN,OTHER,IBRF) ;
  1. N IBX,X,Y,DD,DO,DA,DIC,DLAYGO
  1. S IBX=0 S DRUG=$$DRUG($G(DRUG)) G:'DRUG ADDE
  1. S DIC="^IBA(362.4,",DIC(0)="AQL",X=RX,DLAYGO=362.4 D FILE^DICN
  1. I Y>0 D
  1. . ; IB *2.0*432 Stuff ISSUE DATE from file 52 when adding new RX to 362.4
  1. . D ORDT($P(OTHER,U,4),+Y)
  1. . 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) S:$L($G(IBRF)) DR=DR_";.1////"_IBRF D ^DIE K DIE,DIC,DA,DR
  1. . S DGRVRCAL=1
  1. ADDE Q IBX
  1. ;
  1. EDIT(PIFN,REVIEN) ;
  1. N IBCHG,DIE,DR,DA,DIC,DIDEL,IBORDT
  1. ; IB*2.0*432 - display RX Order date to user, if available
  1. S IBORDT=$P($G(^IBA(362.4,PIFN,0)),U,11)
  1. W:IBORDT'="" !,"Date RX Ordered: ",$$FMTE^XLFDT(IBORDT)
  1. S DIDEL=362.4,DIE="^IBA(362.4,"
  1. S DR=".01;.03;.04;.06;.07;.08;.09;.1"
  1. S DA=PIFN D ^DIE
  1. I '$D(^IBA(362.4,PIFN,0)),$G(REVIEN) D ; Deleted RX - delete related rev code/CPT code
  1. . 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
  1. . S DA=REVIEN,DA(1)=IBIFN,DIK="^DGCR(399,"_DA(1)_",""RC""," D ^DIK
  1. . S DGRVRCAL=1
  1. Q
  1. ;
  1. SET(IFN,RXARR,RXARRP) ;setup array of all rx fills for bill, array name should be passed by reference
  1. ;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)^ORDER DATE
  1. ; RXARR=BILL IFN ^ RX count
  1. N CNT,IBX,IBY,IBZ,PIFN,IBC,IBCNT,IBRC S IBCNT=+$G(RXARRP),IBC="AIFN"_$G(IFN) K RXARR,RXARRP
  1. ;
  1. D RCITEM(IFN,"IBRC",3)
  1. 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
  1. .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)
  1. . I $G(IFN) S $P(RXARR($P(IBY,U),+$P(IBY,U,3)),U,7)=$$FINDREV(IFN,3,PIFN)
  1. . S $P(RXARR($P(IBY,U),+$P(IBY,U,3)),U,8)=$P(IBY,U,9)
  1. . ; IB *2.0*432 include ORDER DATE from file 362.4 in output formatter
  1. . S $P(RXARR($P(IBY,U),+$P(IBY,U,3)),U,9)=$P(IBY,U,11)
  1. ;
  1. S RXARR=$G(IFN)_"^"_CNT
  1. 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)
  1. Q
  1. ;
  1. 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
  1. N IBX,IBY,IBZ,IBS,IBP,IBIFN
  1. W !!,?5,"----------------- Existing Prescriptions on Bill -----------------",!
  1. S IBIFN=+$G(RXARR)
  1. 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
  1. . S IBS=$$RXSTAT^IBCU1(+$P(RXARR(IBX,IBY),U,2),+$P($G(^IBA(362.4,+RXARR(IBX,IBY),0)),U,5),IBY)
  1. . D ZERO^IBRXUTL(+$P(RXARR(IBX,IBY),U,2))
  1. . S IBZ=$G(^TMP($J,"IBDRUG",+$P(RXARR(IBX,IBY),U,2),.01)),IBP=$$PRVNM(+RXARR(IBX,IBY))
  1. . K ^TMP($J,"IBDRUG")
  1. . 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)
  1. . S IBZ=$$RXDUP^IBCU3(IBX,IBY,IBIFN) I +IBZ W ?73,$P($G(^DGCR(399,+IBZ,0)),U,1)
  1. . S IBZ=$G(^DGCR(399,IBIFN,"RC",+$P(RXARR(IBX,IBY),U,7),0))
  1. . 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"),")"
  1. W !
  1. Q
  1. ;
  1. HELP(IFN) ;called for help from rx enter to display existing rx, displays rx' from 52 and 399
  1. 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)
  1. Q
  1. BILL(IBIFN) ; return data on a bill 'patient ifn ^ from dt ^ to dt ^ true if add original rx'
  1. N IBX,IBY
  1. S IBX=$G(^DGCR(399,+$G(IBIFN),0)),IBY=$P(IBX,U,2)
  1. I '$$PERDIEM^IBCRU3(+$P(IBX,U,7),+$P(IBX,U,5),+$P(IBX,U,3)) S $P(IBY,U,4)=1
  1. S IBX=$G(^DGCR(399,+IBIFN,"U")),$P(IBY,U,2)=+IBX,$P(IBY,U,3)=+$P(IBX,U,2)
  1. Q IBY
  1. DRUG(IBD) ; get drug
  1. 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
  1. Q IBD
  1. ;
  1. RCITEM(IBIFN,ARRAY,TYPE) ; Pull off all item charges from RC multiple
  1. ; for item TYPE on bill IBIFN, return array ARRAY
  1. ; If type = "ALL", pull off all types
  1. ;Set up @ARRAY@(type,item reference,ct)=# units^unit charge
  1. ; If no pointer to an item, this was a manually entered charge and
  1. ; will only 'associate' with the items found in the appropriate
  1. ; item source file that are not referenced by an item in the revenue
  1. ; code multiple in a sequential fashion (first unassociated 'RC' will
  1. ; correlate to the first unassociated entry found for the bill in source file)
  1. N Z,Z0,Z1
  1. S Z=0
  1. 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)
  1. Q
  1. ;
  1. FINDREV(IBIFN,TYP,PTR) ; Finds the first revenue code that matches the
  1. ; same item type and item pointer
  1. ;
  1. N REVIEN,Z,Z0
  1. S Z=0
  1. 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
  1. Q $G(REVIEN)
  1. ;
  1. NDCNUM(IBNDC) ; Returns the format of the NDC # IBNDC, if possible
  1. N Z
  1. S Z=$TR(IBNDC,"-")
  1. 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:"")
  1. ;
  1. PRVNM(PIFN) ; return provider name for an rx, if one defined or null
  1. N IBX,IBPRV,IBRXIFN S IBPRV=""
  1. 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)
  1. Q IBPRV
  1. ORDT(IBORDT,Y) ;get ISSUE DATE from file 52 and stuff into ORDER DATE of file 362.4
  1. Q:IBORDT=""
  1. N DIE,DA,DR
  1. S DIE=362.4,DA=+Y,DR=".11///"_IBORDT D ^DIE
  1. Q