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

PSOCPBK2.m

Go to the documentation of this file.
  1. PSOCPBK2 ;BIR/EJW,GN-Tally Automated-release refill copay cont. ;8/10/05 12:03pm
  1. ;;7.0;OUTPATIENT PHARMACY;**215,303,460**;DEC 1997;Build 32
  1. ;External reference to ^PSDRUG supported by DBIA 221
  1. ;External reference to ^IBAM(354.7 supported by DBIA 3877
  1. ;External reference to $$PROD^XUPROD(1) supported by DBIA 4440
  1. ;External reference to $$CPTIER^PSNAPIS(P1,P3) supported by DBIA #2531
  1. ;External reference to ^XMB(1 supported by DBIA #10091
  1. ;
  1. TALLY ;
  1. ; IF NO IB NUMBER FOR THIS FILL, SET UP VARIABLES AND TALLY
  1. N PSOCAP,PSODIV,PSODV,PSOFILL,PSOLOG,PSOOUT,PSOPAR,PSOPATID,PSOSITE
  1. N PSOSITE7,PSOSQ,PSOTOT,PSOYEAR,PSOYR,SSN
  1. S PSODFN=0
  1. F QQ=1:1 S PSODFN=$O(^XTMP(NAMSP,PSODFN)) Q:'PSODFN D Q:STOP
  1. .I QQ#100=0,$D(^XTMP(NAMSP,0,"STOP")) K ^XTMP(NAMSP) S STOP=1
  1. .S (PSOCAP(304),PSOCAP(305))=0 ; INITIAL ANNUAL CAP FOR 2004 & 2005
  1. .F RXP=0:0 S RXP=$O(^XTMP(NAMSP,PSODFN,RXP)) Q:'RXP D
  1. ..F YY=0:0 S YY=$O(^XTMP(NAMSP,PSODFN,RXP,YY)) Q:YY="" D
  1. ...S PSOREL=$G(^XTMP(NAMSP,PSODFN,RXP,YY))
  1. ...I PSOCAP($E(PSOREL,1,3)) Q ; MET ANNUAL CAP FOR 2004 OR 2005
  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. ;set refill number if this is a refill
  1. I $G(^PSRX(RXP,1,+$G(YY),0))]"" S PSOREF=YY
  1. ;
  1. ;Orig fill -check if bill # already exists
  1. I 'PSOREF,+$P($G(^PSRX(RXP,"IB")),"^",2)>0 D CHKIB^PSOCP1
  1. I PSOIB G QUIT
  1. ;already attempted to bill, but exceeded Anuual Cap
  1. I 'PSOREF,+$P($G(^PSRX(RXP,"IB")),"^",4)>0 G QUIT
  1. ;
  1. ;Refill -check if bill # already exists
  1. I PSOREF,+$G(^PSRX(RXP,1,PSOREF,"IB")) D CHKIB^PSOCP1
  1. I PSOIB G QUIT
  1. ;already attempted to bill, but exceeded Anuual Cap
  1. I PSOREF,+$P($G(^PSRX(RXP,1,PSOREF,"IB")),"^",2) G QUIT
  1. ;
  1. ;set temporary variable to copay and then look for exceptions
  1. S PSOCHG=1
  1. D COPAYREL
  1. I 'PSOCHG G QUIT ;not billable
  1. I PSOCHG=2 I 'PSOCP G QUIT
  1. ; Units for COPAY
  1. ;calc number of 30-day units eligible to bill
  1. S PSOCPUN=($P(^PSRX(RXP,0),"^",8)+29)\30
  1. D ACCUM
  1. QUIT ;
  1. K Y,PSOCP1,PSOCP2,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,PSOEXMPT
  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,PSOEXMPT=1 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 '$G(PSOEXMPT),$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="304":"YR2004",PSOYR="305":"YR2005",1:"")
  1. Q:PSOYEAR=""
  1. ;
  1. ;get Xtmp billing amt which would be IBAM tot + any previous refills
  1. S PSOTOT=$G(^XTMP(NAMSP,PSODFN,PSOYEAR))
  1. ;
  1. ;if none yegt then init to the IBAM total for the year
  1. I 'PSOTOT D
  1. .F PSOSQ=0:0 S PSOSQ=$O(^IBAM(354.7,PSODFN,1,PSOSQ)) Q:'PSOSQ D
  1. ..S PSOLOG=$G(^IBAM(354.7,PSODFN,1,PSOSQ,0))
  1. ..I $E(PSOLOG,1,3)=PSOYR S PSOTOT=PSOTOT+$P(PSOLOG,"^",2)
  1. ;
  1. ;see if current refill added to tot exceeds annual cap and quit
  1. I PSOTOT+(7*PSOCPUN)>840 S PSOCAP(PSOYR)=1 Q
  1. ;
  1. ;update Xtmp tot nodes with current refill amounts
  1. S ^XTMP(NAMSP,PSODFN,PSOYEAR)=PSOTOT+(PSOCPUN*7)
  1. S ^XTMP(NAMSP,PSODFN,PSOYEAR,PSOCPUN)=$G(^XTMP(NAMSP,PSODFN,PSOYEAR,PSOCPUN))+1
  1. ;
  1. ;indicate this refill would be billable by adding to Xtmp "BILLED"
  1. N PSONAM
  1. S PSONAM=$P($G(^DPT(PSODFN,0)),"^"),PSONAM=$P(PSONAM,",")
  1. S PSONAM=$E(PSONAM,1,6)
  1. S ^XTMP(NAMSP,"BILLED",PSONAM,PSODFN,RXP,PSOREF)=PSOREL
  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. Q:PSOSITE=""
  1. S PSOPAR=$G(^PS(59,PSOSITE,1))
  1. S PSOSITE7=$P($G(^PS(59,PSOSITE,"IB")),"^")
  1. Q
  1. ;
  1. RPT ;
  1. N NAMSP S NAMSP=$$NAMSP^PSOCPBK1
  1. L +^XTMP(NAMSP):0 I '$T D Q
  1. . W !,"Copay Tally job for PSO*7*215 is still running. Halting..."
  1. L -^XTMP(NAMSP)
  1. W !!,"This report shows the patient name and prescription information for refills"
  1. W !,"that were indentified as billable by the tally patch PSO*7*215"
  1. W !!,"You may queue the report to print, if you wish.",!
  1. ;
  1. DVC K %ZIS,POP,IOP S %ZIS="QM" D ^%ZIS I $G(POP) W !!,"Nothing queued to print.",! G DONE
  1. QUEUE I $D(IO("Q")) S ZTRTN="START^PSOCPBK2",ZTDESC="Potential Billable copay report" D ^%ZTLOAD K %ZSI W !,"Report queued to print.",! G DONE
  1. START ;
  1. U IO
  1. N NAMSP S NAMSP=$$NAMSP^PSOCPBK1
  1. S PSOOUT=0,PSODV=$S($E(IOST)="C":"C",1:"P")
  1. S PSOPGCT=0,PSOPGLN=IOSL-7,PSOPGCT=1
  1. D TITLE
  1. S PSONAM=""
  1. F S PSONAM=$O(^XTMP(NAMSP,"BILLED",PSONAM)) Q:PSONAM="" D
  1. .S PSODFN=""
  1. .F S PSODFN=$O(^XTMP(NAMSP,"BILLED",PSONAM,PSODFN)) Q:PSODFN="" D
  1. ..S RXP=""
  1. ..F S RXP=$O(^XTMP(NAMSP,"BILLED",PSONAM,PSODFN,RXP)) Q:RXP="" D
  1. ...S PSOFILL=""
  1. ...F S PSOFILL=$O(^XTMP(NAMSP,"BILLED",PSONAM,PSODFN,RXP,PSOFILL)) Q:PSOFILL="" D
  1. ....N XX,PSONAME
  1. ....S XX=$G(^XTMP(NAMSP,"BILLED",PSONAM,PSODFN,RXP,PSOFILL)) D
  1. .....D FULL Q:$G(PSOOUT) S PSONAME=$P($G(^DPT(PSODFN,0)),"^")
  1. .....W !,$E(PSONAME,1,14) D PRTSSN
  1. .....W ?46," ",RXP," (",PSOFILL,")" D
  1. ......S Y=XX I Y>0 X ^DD("DD")
  1. ......W ?65," ",Y
  1. G END
  1. ;
  1. FULL ;
  1. I ($Y+7)>IOSL&('$G(PSOOUT)) D TITLE
  1. Q
  1. ;
  1. TITLE ;
  1. I $G(PSODV)="C",$G(PSOPGCT)'=1 W ! K DIR S DIR(0)="E" D ^DIR K DIR I 'Y S PSOOUT=1 Q
  1. ;
  1. W @IOF D
  1. . W !,"Patch PSO*7*215 -COPAY PRESCRIPTION REFILLS BILLABLE"
  1. S Y=DT X ^DD("DD") W !,"Date printed: ",Y,?70,"Page: ",PSOPGCT,!
  1. F MJT=1:1:79 W "="
  1. W !,"PATIENT NAME (SSN) DIV",?48,"RX# (FILL)",?66,"RELEASE DATE"
  1. W !,"-------------- ------- ----------------",?47,"------------"
  1. W ?66,"------------"
  1. S PSOPGCT=PSOPGCT+1
  1. Q
  1. END ;
  1. I '$G(PSOOUT),$G(PSODV)="C" W !!,"** End of Report **" K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
  1. I $G(PSODV)="C" W !
  1. E W @IOF
  1. DONE ;
  1. K MJT,PSOPGCT,PSOPGLN,Y,DIR,X,IOP,POP,IO("Q"),DIRUT,DUOUT,DTOUT
  1. D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
  1. Q
  1. ;
  1. PRTSSN ;
  1. S SSN=$P(^DPT(PSODFN,0),"^",9),SSN=$E(SSN,$L(SSN)-3,$L(SSN))
  1. S PSOPATID=$E(PSONAM,1)_SSN
  1. S PSODIV=$P($G(^PSRX(RXP,2)),"^",9)
  1. S:PSODIV'="" PSODIV=$P($G(^PS(59,PSODIV,0)),"^",1)
  1. W " ("_PSOPATID_")"_" "_PSODIV
  1. Q
  1. ;
  1. ETIME(SECTIME) ;convert seconds to day:hr:min:sec
  1. N DAY,HR,MIN,SEC,ETIM
  1. S (DAY,HR,MIN,SEC)=""
  1. I SECTIME>86400 S DAY=SECTIME\86400,SECTIME=SECTIME#86400
  1. I SECTIME>3600 S HR=SECTIME\3600,SECTIME=SECTIME#3600
  1. I SECTIME>60 S MIN=SECTIME\60,SECTIME=SECTIME#60
  1. S SEC=SECTIME
  1. S ETIM=""
  1. S:$L(HR)=1 HR=0_HR S:$L(MIN)=1 MIN=0_MIN S:$L(SEC)=1 SEC=0_SEC
  1. S:DAY ETIM=DAY_" Day " S:HR ETIM=ETIM_HR_":" S:MIN ETIM=ETIM_MIN
  1. S ETIM=ETIM_":"_SEC
  1. Q ETIM
  1. ;
  1. MAIL3(MSG) ;
  1. S PSOINST=$P($G(^DIC(4,+$P($G(^XMB(1,1,"XUS")),"^",17),99)),"^")
  1. D NOW^%DTC S Y=% D DD^%DT S PSOEND=Y
  1. K PSOTEXT
  1. S XMY(DUZ)=""
  1. S XMY("NAPOLIELLO.GREG@DOMAIN.EXT")=""
  1. S XMY("WHITE.ELAINE@DOMAIN.EXT")=""
  1. S:$$PROD^XUPROD(1) XMY("WILLIAMSON.ERIC@DOMAIN.EXT")=""
  1. S XMDUZ="PSO*7*215 TALLY"
  1. S XMSUB="STATION "_$G(PSOINST)
  1. S XMSUB=XMSUB_$S($$PROD^XUPROD(1):"(Prod)",1:"(Test)")
  1. S XMSUB=XMSUB_" UNBILLED COPAYS FOR PRESCRIPTION REFILLS"
  1. S PSOTEXT(1)=""
  1. S PSOTEXT(2)="Started "_PSOSTART
  1. S PSOTEXT(3)=""
  1. S PSOTEXT(4)=" "_MSG
  1. S XMTEXT="PSOTEXT(" N DIFROM D ^XMD K XMDUZ,XMTEXT,XMSUB
  1. Q