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

PSOCPBA2.m

Go to the documentation of this file. 
  1. PSOCPBA2 ;BIR/EJW-PHARMACY CO-PAY APPLICATION UTILITIES FOR IB ;03/29/03
  1.  ;;7.0;OUTPATIENT PHARMACY;**137,303,460**;DEC 1997;Build 32
  1.  ;
  1.  ;External reference to ^PSDRUG supported by DBIA 221
  1.  ;External reference to ^IBAM(354.7 supported by DBIA 3877
  1.  ;External reference to $$CPTIER^PSNAPIS(P1,P3) supported by DBIA #2531
  1. TALLY ;
  1.  ; IF NO IB NUMBER FOR THIS FILL, SET UP VARIABLES AND TALLY
  1.  S PSODFN="" F  S PSODFN=$O(^XTMP("PSOCPBAK",$J,PSODFN)) Q:'PSODFN  D
  1.  .I $G(^XTMP("PSOCPBAK",$J,PSODFN)) Q  ; EXEMPT OR SC QUESTION APPLIES
  1.  .S (PSOCAP(302),PSOCAP(303))=0 ; INITIAL ANNUAL CAP FLAG FOR PATIENT FOR 2002 AND 2003
  1.  .S RXP="" F  S RXP=$O(^XTMP("PSOCPBAK",$J,PSODFN,RXP)) Q:'RXP  S YY=""  F  S YY=$O(^XTMP("PSOCPBAK",$J,PSODFN,RXP,YY)) Q:YY=""  D
  1.  ..S PSOREL=$G(^XTMP("PSOCPBAK",$J,PSODFN,RXP,YY))
  1.  ..I PSOCAP($E(PSOREL,1,3)) Q  ; MET ANNUAL CAP FOR 2002 OR 2003
  1.  ..I 'YY D  Q
  1.  ...I $P($G(^PSRX(RXP,"IB")),"^",2)'="" Q  ; ALREADY BILLED
  1.  ...D SITE
  1.  ...D CP
  1.  ..I $P($G(^PSRX(RXP,1,YY,"IB")),"^",1)="" D  ; REFILL LEVEL
  1.  ...D SITE
  1.  ...D CP
  1.  Q
  1.  ;
  1. CP ; Entry point to Check if COPAY  -   Requires RXP,PSOSITE7
  1.  I '$D(PSOPAR) D ^PSOLSET G CP
  1.  K PSOCP
  1.  S PSOCPN=$P(^PSRX(RXP,0),"^",2) ; Set COPAY dfn PTR TO PATIENT
  1.  S PSOCP=$P($G(^PSRX(RXP,"IB")),"^") ; IB action type
  1.  S PSOSAVE=$S(PSOCP:1,1:"") ; save current copay status
  1.  ;         Set x=service^dfn^actiontype^user duz
  1.  I +$G(PSOSITE7)'>0 S PSOSITE7=$P(^PS(59,PSOSITE,"IB"),"^")
  1.  S X=PSOSITE7_"^"_PSOCPN_"^"_PSOCP_"^"_$P(^PSRX(RXP,0),"^",16)
  1.  ;
  1. RX ;         Determine Original or Refill for RX
  1.  N PSOIB
  1.  S PSOIB=0
  1.  S PSOREF=0
  1.  I $G(^PSRX(RXP,1,+$G(YY),0))]"" S PSOREF=YY
  1.  ;         Check if bill # already exists for this RX or Refill
  1.  I 'PSOREF,+$P($G(^PSRX(RXP,"IB")),"^",2)>0 D CHKIB^PSOCP1 I PSOIB G QUIT
  1.  I 'PSOREF,+$P($G(^PSRX(RXP,"IB")),"^",4)>0 G QUIT ; 'POTENTIAL BILL' - ALREADY ATTEMPTED TO BILL, BUT EXCEEDED ANNUAL COPAY CAP
  1.  I PSOREF,+$G(^PSRX(RXP,1,PSOREF,"IB")) D CHKIB^PSOCP1 I PSOIB G QUIT
  1.  I PSOREF,+$P($G(^PSRX(RXP,1,PSOREF,"IB")),"^",2) G QUIT ; POTENTIAL BILL
  1.  S PSOCHG=1 ; set temporary variable to copay and then look for exceptions
  1.  D COPAYREL
  1.  I 'PSOCHG G QUIT ; NOT BILLABLE
  1.  I PSOCHG=2 I 'PSOCP G QUIT
  1.  ;         Units for COPAY
  1.  S PSOCPUN=$P(($P(^PSRX(RXP,0),"^",8)+29)/30,".",1) ; NUMBER OF 30-DAY UNITS ELIGIBLE TO BILL
  1.  D ACCUM
  1. QUIT ;
  1.  K Y,PSOCP1,PSOCP2,QQ,PSOCPN,X,PSOCPUN,PSOREF,PSOCHG,PSOSAVE,PREA,PSORSN,PSOCOMM,PSOOLD,PSONW,PSODA
  1.  Q
  1.  ;
  1. COPAYREL ; Recheck copay status at release
  1.  ;
  1.  ; check Rx patient status
  1.  I $P(^PSRX(RXP,0),"^",3)'="",$P($G(^PS(53,$P(^PSRX(RXP,0),"^",3),0)),"^",7)=1 S PSOCHG=0 Q
  1.  ; see if drug is nutritional supplement, investigational or supply
  1.  N DRG,DRGTYP
  1.  S DRG=+$P(^PSRX(RXP,0),"^",6),DRGTYP=$P($G(^PSDRUG(DRG,0)),"^",3)
  1.  I DRGTYP["I"!(DRGTYP["S")!(DRGTYP["N") S PSOCHG=0 Q
  1.  K PSOTG,CHKXTYPE
  1.  I +$G(^PSRX(RXP,"IBQ")) D XTYPE1^PSOCP1
  1.  I $G(^PSRX(RXP,"IBQ"))["1" S PSOCHG=0 Q
  1.  ;***** begin - for regression test - sites must not use this as it will adversely affect billing results - only used by SQA
  1.  ; The following is required for testing different effective dates.  If date is less than 02/27/17 bills old way.  Otherwise bills new way.
  1.  ;S ^XTMP("PSOTIEREFTST",0)="3201231^3170227^FOR SQA TESTING ONLY" - Defined for SQA testing only.   Delete this XTMP when regression complete
  1.  D NOW^%DTC N PSOTIERE
  1.  S PSOTIERE=1  ;use copay tiers - new
  1.  I $P(%,".")<3170227 S PSOTIERE=0  ;legacy billing - old
  1.  I $G(^XTMP("PSOTIEREFTST",0)) S PSOTIERE=1  ;for SQA testing only - bill with copay tiers - new
  1.  ;***** end for regression test
  1.  G COPAYRE1:'PSOTIERE
  1.  ; check copay tier. Tier zero does not have copay charges
  1.  N CPDATE,X,PSOCPT D NOW^%DTC S CPDATE=X S PSOCPT=$$CPTIER^PSNAPIS("",CPDATE,DRG) K CPDATE,X
  1.  I $P(PSOCPT,"^")=0 S PSOCHG=0 Q   ;Tier zero do not send to IB for copay charge
  1.  I $P(PSOCPT,"^")'=0 S PSOCOMM="",PSOOLD="No Copay",PSONW="Copay" S PSODA=RXP,PREA="R" D ACTLOG^PSOCPA
  1. COPAYRE1 ;
  1.  Q
  1.  ;
  1. ACCUM ; ACCUMULATE TOTALS AND SEE IF PATIENT MET ANNUAL CAP
  1.  S PSOYR=$E(PSOREL,1,3) I PSOYR="" Q
  1.  S PSOYEAR=$S(PSOYR="302":"YR2002",PSOYR="303":"YR2003",1:"") I PSOYEAR="" Q
  1.  S PSOTOT=$G(^XTMP("PSOCPBAK",$J,PSODFN,PSOYEAR))
  1.  I 'PSOTOT D
  1.  .S PSOSQ="" F  S PSOSQ=$O(^IBAM(354.7,PSODFN,1,PSOSQ)) Q:'PSOSQ  S PSOLOG=$G(^IBAM(354.7,PSODFN,1,PSOSQ,0)) I $E(PSOLOG,1,3)=PSOYR D
  1.  ..S PSOTOT=PSOTOT+$P(PSOLOG,"^",2)
  1.  I PSOTOT+(7*PSOCPUN)>840 S PSOCAP(PSOYR)=1 Q  ; BILLING FOR THIS WOULD EXCEED ANNUAL CAP
  1.  S ^XTMP("PSOCPBAK",$J,PSODFN,PSOYEAR)=PSOTOT+(PSOCPUN*7)
  1.  S ^XTMP("PSOCPBAK",$J,PSODFN,PSOYEAR,PSOCPUN)=$G(^XTMP("PSOCPBAK",$J,PSODFN,PSOYEAR,PSOCPUN))+1
  1.  Q
  1.  ;
  1. SITE ; SET UP VARIABLES NEEDED BY BILLING
  1.  S PSOSITE=$S(YY=0:$P(^PSRX(RXP,2),"^",9),1:$P($G(^PSRX(RXP,1,YY,0)),"^",9))
  1.  I PSOSITE="" Q
  1.  S PSOPAR=$G(^PS(59,PSOSITE,1))
  1.  S PSOSITE7=$P($G(^PS(59,PSOSITE,"IB")),"^")
  1.  Q