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

IBARX1.m

Go to the documentation of this file. 
  1. IBARX1 ;ALB/AAS - INTEGRATED BILLING, PHARMACY COPAY INTERFACE (CONT.) ; 21-FEB-91
  1.  ;;2.0;INTEGRATED BILLING;**34,101,150,158,156,234,247,563,614,651,653**;21-MAR-94;Build 19
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  ;
  1.  ;  - process 1 rx entry and accumulate totals
  1.  ;  ICR 2056   - $$GET1^DIQ
  1.  ;  ICR 4820     RX^PSO52API
  1.  ;
  1. RX N IBAM,IBNOCH,IBTIER
  1.  ;if Combat Vet send alert e-mail to mailgroup "IB COMBAT VET RX COPAY"
  1.  D
  1.  . N Y D NOW^%DTC S Y=%\1
  1.  . D RXALRT^IBACV(DFN,Y,+$P($P($G(IBSAVX(1)),"^",1),":",2))
  1.  ;
  1.  I $P(IBX,"^")'?1.N1":"1.N.ANP S Y="-1^IB012" G RXQ
  1.  I $P(IBX,"^",2)<1 S Y="-1^IB013" G RXQ
  1.  ;
  1.  D BDESC
  1.  ;
  1.  ; make sure effective date defined
  1.  S IBEFDT=$G(IBEFDT,DT)
  1.  ; determine rx copay copay tier
  1.  S IBTIER=$$RXTIER^IBAUTL(DFN,+$P($P(IBX,"^"),":",2),IBEFDT)
  1.  ; determine rx cost
  1.  S DA=IBATYP D COST^IBAUTL I $P($G(Y),"^")=-1 G RXQ
  1.  ;
  1.  ; IB*2.0*614  Prorate rx's with less than 30 day supply if National HRfS flag is active
  1.  ; Check for an original fill or a refill.
  1.  N IBISDT,IBRXN,IBRFN,IBLIST,IBDATA,IBLSRF S IBRXN=+$P($P(IBX,"^"),":",2)  ;IBRXN = IEN of the Drug file
  1.  S IBLIST="IBARX1" K ^TMP($J,IBLIST)
  1.  D RX^PSO52API(DFN,IBLIST,IBRXN,,"2,R,I") S IBDATA=$NA(^TMP($J,IBLIST,DFN,IBRXN))
  1.  S IBISDT=+@IBDATA@(1)  ;Get original released date (field 31)
  1.  ;
  1.  S IBLSRF=$O(@IBDATA@("RF","A"),-1)  ;get last refill
  1.  I IBLSRF D   ;If this is a refill use the refill date to prorate amount billed
  1.  . I $G(@IBDATA@("RF",IBLSRF,17))="" Q   ;Check released date/time quit if not released
  1.  . S IBISDT=+@IBDATA@("RF",IBLSRF,17)  ;Reset fill date to date of refill
  1.  ;
  1.  ; X1 - standard  calculated amount for this tier #
  1.  ; IB*2.0*653  calculate flat rate Rx's copay amount if National HRfS flag is active
  1.  ; if rate is above 0, and the Pt has an active HRfS flag at the date of fill/refill, and # of days is greater than 0, then set rate to $2
  1.  I X1,$$CHKHRFS^IBAMTS3(DFN,IBISDT) S:@IBDATA@(8)>0 X1=2
  1.  K ^TMP($J,"IBARX1")
  1.  ;
  1.  ; compute amount above cap
  1.  D NEW^IBARXMC($P(IBX,"^",2),X1,DT,.IBCHRG,.IBNOCH)
  1.  ;
  1.  S IBTCH=$P(IBX,"^",2)*X1
  1.  ;
  1.  ; add to 354.71
  1.  S IBAM=$$ADD^IBARXMN(DFN,"^^"_IBEFDT_"^^P^"_$P(IBX,"^")_"^"_$P(IBX,"^",2)_"^"_IBTCH_"^"_IBDESC_"^"_$S($G(IBAMP):IBAMP,1:"")_"^"_IBCHRG_"^"_IBNOCH_"^"_(+$P($$SITE^IBARXMU,"^",3))_"^^^^^^^"_$G(IBTIER),IBATYP) I IBAM<1 S Y="-1^IB316" G RXQ
  1.  ;
  1.  ; setup new pieces (4, 5, 6, and 7), quit if above cap
  1.  S $P(IBSAVY(IBJ),"^",4,7)=$S(IBNOCH:1,1:0)_"^"_$S(IBNOCH&(IBCHRG):"P",IBCHRG:"F",1:"")_"^"_(+$G(IBEXMP))_"^"_IBAM G:'IBCHRG RXQ
  1.  ;
  1.  S IBTOTL=IBTOTL+IBCHRG
  1.  S IBWHER=2
  1.  D ADD^IBAUTL
  1.  I +Y<1 G RXQ
  1.  S IBPARNT=$S($D(IBPARNT):IBPARNT,1:IBN)
  1.  ;IB*2.0*651 - Add now as event date
  1.  S $P(^IB(IBN,1),"^")=IBDUZ
  1.  S $P(^IB(IBN,0),"^",2,17)=DFN_"^"_IBATYP_"^"_$P(IBX,"^")_"^2^"_$P(IBX,"^",2)_"^"_IBCHRG_"^"_IBDESC_"^"_IBPARNT_"^^"_IBIL_"^"_IBTRAN_"^"_IBFAC_"^"_IBEFDT_"^"_IBEFDT_"^^"_$$NOW^XLFDT(),$P(^(0),"^",19,22)=IBAM_"^^^"_$G(IBTIER)
  1.  K IBPARNT,^IB("AC",1,IBN) ;S ^IB("AC",2,IBN)=""
  1.  D INDEX
  1.  S $P(IBSAVY(IBJ),"^",1,3)=IBN_"^"_IBCHRG_"^"_IBIL
  1.  S:'$D(IBNOS) IBNOS="" S IBNOS=IBN_"^"_IBNOS
  1. RXQ Q
  1.  ;
  1. CANRX ;  - ibx = ibn for parent entry
  1.  ;  - ibn = new cancellation entry
  1.  N IBAM,IBAMY,IBEFDT,IBTIER
  1.  S IBY(IBJ)=1
  1.  I '$D(^IBE(350.3,+$P(IBX,"^",2),0)) S (Y,IBY(IBJ))="-1^IB020" G CANRXQ
  1.  I '$D(^IB(+IBX,0)) S (Y,IBY(IBJ))="-1^IB021" G CANRXQ
  1.  S IBND=^IB(+IBX,0)
  1.  S IBCRES=$P(IBX,"^",2)
  1.  ;  -find most recent entry for parent ibx
  1.  ;  -if status isn't an update or new, error already cancelled?
  1.  D LAST I IBLAST'=IBPARNT,$D(^IB(IBLAST,0)),$P(^IBE(350.1,$P(^IB(IBLAST,0),"^",3),0),"^",5)=2 S (Y,IBY(IBJ))="-1^IB026^ Ref. No: "_+^IB(+IBLAST,0) G CANRXQ ;already cancelled
  1.  ;
  1.  ; cancel 354.71
  1.  S IBAM=$$CANCEL^IBARXMN(DFN,$P(IBND,"^",19),.IBAMY,IBCRES) I $G(IBAMY)<0 S (Y,IBY(IBJ))=IBAMY G CANRXQ
  1.  ;
  1.  I $P(IBND,"^",5)=8 D  QUIT  ;Cancel a charge with a status of HOLD
  1.  . N DIE,DA,DR
  1.  . S DIE="^IB(",DA=+IBX,DR=".05////10;.1////"_IBCRES
  1.  . DO ^DIE
  1.  . S Y=1,IBY(IBJ)=1,Y(IBJ)=+IBX
  1.  ;
  1.  S IBPARNT=$P(IBND,"^",9) I '$D(^IB(IBPARNT,0)) S (Y,IBY(IBJ))="-1^IB027" G CANRXQ
  1.  S IBATYP=$P(^IBE(350.1,$P(IBND,"^",3),0),"^",6) ;cancellation action type for parent
  1.  I '$D(^IBE(350.1,+IBATYP,0)) S (Y,IBY(IBJ))="-1^IB022" G CANRXQ
  1.  S IBSEQNO=$P(^IBE(350.1,+IBATYP,0),"^",5) I 'IBSEQNO S (Y,IBY(IBJ))="-1^IB023" G CANRXQ
  1.  S IBIL=$P(IBND,"^",11) I IBIL="" S (Y,IBY(IBJ))="-1^IB024" G CANRXQ
  1.  S IBUNIT=$S($D(^IB(+IBLAST,0)):$P(^(0),"^",6),1:$P(IBND,"^",6)) I IBUNIT<1 S (Y,IBY(IBJ))="-1^IB025" G CANRXQ
  1.  S IBCHRG=$S($D(^IB(+IBLAST,0)):$P(^(0),"^",7),1:$P(IBND,"^",7)) I IBCHRG<1 S (Y,IBY(IBJ))="-1^IB025" G CANRXQ
  1.  S IBEFDT=$S($P(IBND,"^",14):$P(IBND,"^",14),1:$P($G(^IB(+IBX,1)),"^",2))
  1.  S IBTIER=$P(IBND,"^",22)
  1.  S IBTOTL=IBTOTL+IBCHRG
  1.  S IBWHER=2
  1.  D ADD^IBAUTL I +Y<1 S IBY(IBJ)=Y G CANRXQ
  1.  S $P(^IB(IBN,1),"^",1)=IBDUZ
  1.  S $P(^IB(IBN,0),"^",2,15)=DFN_"^"_IBATYP_"^"_$P(IBND,"^",4)_"^2^"_IBUNIT_"^"_IBCHRG_"^"_$P(IBND,"^",8)_"^"_IBPARNT_"^"_IBCRES_"^"_IBIL_"^^"_IBFAC_"^"_IBEFDT_"^"_IBEFDT S:IBAM $P(^(0),"^",19)=IBAM S:IBTIER $P(^(0),"^",22)=IBTIER
  1.  K ^IB("AC",1,IBN) ;S ^IB("AC",2,IBN)=""
  1.  D INDEX
  1.  S Y(IBJ)=IBN_"^"_IBCHRG_"^"_IBIL
  1.  S IBNOS=IBN
  1. CANRXQ Q
  1.  ;
  1. BDESC ;  -return brief description
  1.  N X,Y S IBDESC="",X=$P(IBX,"^")
  1.  I $D(^IBE(350.1,IBATYP,20)) X ^(20) S IBDESC=X
  1.  Q
  1. LAST ;find last entry
  1.  S IBLAST=""
  1.  S IBPARNT=$P(^IB(+IBX,0),"^",9) I 'IBPARNT S IBPARNT=+IBX
  1.  S IBLDT=$O(^IB("APDT",IBPARNT,"")) I +IBLDT F IBL=0:0 S IBL=$O(^IB("APDT",IBPARNT,IBLDT,IBL)) Q:'IBL  S IBLAST=IBL
  1.  I IBLAST="" S IBLAST=IBPARNT
  1.  Q
  1.  ;
  1. INDEX ;cross-reference entry
  1.  N X,Y
  1.  S DA=IBN,DIK="^IB(" D IX^DIK
  1.  K DIK Q
  1.  ;
  1. SERV(Y) ; -- Service check for Pharmacy
  1.  ;    called by the screen in the input transform for the IB SERVICE/SECTION
  1.  ;    field of the PHARMACY SITE file.
  1.  ;    input = Y internal entry number in service section file
  1.  ;    output = 1 if okay to use (service matches) or 0 if not okay
  1.  ;
  1.  ; -- screen logic for field 1003 in file 59 should be 
  1.  ;    S DIC("S")="I $$SERV^IBARX1(+Y)"
  1.  ;
  1.  Q $S('$G(Y):0,1:$D(^IBE(350.1,"ANEW",Y,1,1))&$D(^IBE(350.1,"ANEW",Y,1,2)))