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

PSOCPBK4.m

Go to the documentation of this file. 
  1. PSOCPBK4 ;BIR/GN-Copay Back Bill for Automated-release refills cont. ;10/12/05 9:55am
  1.  ;;7.0;OUTPATIENT PHARMACY;**217,303**;DEC 1997;Build 19
  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 $$PTCOV^IBCNSU3 supported by DBIA 4115
  1.  ;External reference to ^IBARX supported by DBIA 125
  1.  ;
  1.  Q
  1.  ;
  1. ADDBILL ;add to billable ^XTMP if ok, quit if not
  1.  S PSOTRF=PSOTRF+1
  1.  S PSOREL=$P($G(^PSRX(RXP,1,YY,0)),"^",18)
  1.  Q:'PSOREL                                   ;not released
  1.  Q:'YY                                       ;orig fill
  1.  Q:+$$RXST^IBARXEU(PSODFN,$P(PSOREL,"."))    ;Exempt on Rel dte
  1.  ;check refill
  1.  Q:$P($G(^PSRX(RXP,1,YY,"IB")),"^",1)'=""    ;already billed
  1.  Q:$P($G(^PSRX(RXP,1,YY,"IB")),"^",2)'=""    ;exceeded ann. cap
  1.  ;
  1.  ;look for Activity log entry per refill # with the below text
  1.  S FOUND=0
  1.  F XX=999:0 S XX=$O(^PSRX(RXP,"A",XX),-1) Q:'XX  D  Q:FOUND
  1.  .Q:$P(^PSRX(RXP,"A",XX,0),"^",4)'=YY
  1.  .Q:^PSRX(RXP,"A",XX,0)'["External Interface Dispensing is Complete"
  1.  .S FOUND=1
  1.  Q:'FOUND
  1.  ;
  1.  S ^XTMP(NAMSP,PSODFN,RXP,YY)=$P(PSOREL,".")  ;add to XTMP to be bill
  1.  Q
  1.  ;
  1. XTYPE ;
  1.  N Y,VADM,I,J,X,SAVY,DFN
  1.  S DFN=PSODFN D DEM^VADPT I +$G(VADM(6)) S PSOSCMX="" Q  ; DECEASED
  1.  S (X,PSOSCMX,SAVY)=""
  1.  S J=0 F  S J=$O(^PS(59,J)) Q:'J  I +$G(^(J,"IB")) S X=+^("IB") Q
  1.  I 'X Q
  1.  S X=X_"^"_PSODFN D XTYPE^IBARX
  1.  I $G(Y)'=1 Q
  1.  S J="" F  S J=$O(Y(J)) Q:'J  S I="" F  S SAVY=I,I=$O(Y(J,I)) Q:I=""  S:I>0 PSOSCMX=I
  1.  I PSOSCMX="",SAVY=0 Q  ; INCOME EXEMPT OR SERVICE-CONNECTED
  1.  I PSOSCMX=2 Q  ; NEED TO ASK SC QUESTION
  1.  Q
  1.  ;
  1. TOTAL ;
  1.  N COUNT,COUNTED
  1.  I '$D(PSOVETS) S PSOVETS=0
  1.  N I,J
  1.  F I=1:1:3 S (PSOCNT("YR2004",I),PSOCNT("YR2005",I))=0
  1.  S PSODFN=0 F  S PSODFN=$O(^XTMP(NAMSP,PSODFN)) Q:'PSODFN  D
  1.  .S COUNTED=0
  1.  .F J="YR2004","YR2005" F I=1:1:3 S COUNT=$G(^XTMP(NAMSP,PSODFN,J,I)) I COUNT>0 S:'$G(COUNTED) COUNTED=1,PSOVETS=PSOVETS+1 S PSOCNT(J,I)=PSOCNT(J,I)+COUNT
  1.  F I=1:1:3 S PSOCNT=PSOCNT+PSOCNT("YR2004",I)+PSOCNT("YR2005",I)
  1.  Q
  1.  ;
  1. BILLIT ;
  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,SAVCPUN,SAVREF
  1.  S PSODFN=0
  1.  F CC=1:1 S PSODFN=$O(^XTMP(NAMSP,PSODFN)) Q:'PSODFN  D  Q:STOP
  1.  .I CC#100=0,$D(^XTMP(NAMSP,0,"STOP")) D  Q
  1.  ..S $P(^XTMP(NAMSP,0,"LAST"),"^",1,2)="STOP^"_$$NOW^XLFDT,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.  ..;calc number of 30-day units eligible to bill
  1.  ..S (SAVCPUN,PSOCPUN)=($P(^PSRX(RXP,0),"^",8)+29)\30
  1.  ..F YY=0:0 S YY=$O(^XTMP(NAMSP,PSODFN,RXP,YY)) Q:YY=""  D
  1.  ...S (SAVREF,PSOREF)=YY
  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^PSOCP                                     ;call back billing
  1.  ....S PSOCPUN=SAVCPUN,PSOREF=SAVREF
  1.  ....I $P($G(^PSRX(RXP,1,YY,"IB")),"^",1) D ACCUM   ;Do if was billed?
  1.  ....D CP I +$G(PSOREF) D ACCUM
  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 D QUIT Q
  1.  ;already attempted to bill, but exceeded Anuual Cap
  1.  I 'PSOREF,+$P($G(^PSRX(RXP,"IB")),"^",4)>0 D QUIT Q
  1.  ;
  1.  ;Refill -check if bill # already exists
  1.  I PSOREF,+$G(^PSRX(RXP,1,PSOREF,"IB")) D CHKIB^PSOCP1
  1.  I PSOIB D QUIT Q
  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 D QUIT Q           ;not billable
  1.  I PSOCHG=2,'PSOCP D QUIT
  1.  Q
  1. QUIT ;
  1.  K Y,PSOCP1,PSOREF,PSOCPUN,PSOCP2,PSOCPN,X,PSOCHG,PSOSAVE,PREA,PSORSN
  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.  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 yet 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.  ;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 may be billable or (was billed, if BILLING run)
  1.  ;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 JOBN,NAMSP,ZTDESC,ZTRTN
  1.  S NAMSP=$$NAMSP^PSOCPBK3
  1.  S JOBN=$S(^XTMP(NAMSP,0)["BACK":"Back Billing",1:"Tally")
  1.  L +^XTMP(NAMSP):0 I '$T D  Q
  1.  .W !,JOBN_" job for PSO*7*217 is still running.  Halting..."
  1.  L -^XTMP(NAMSP)
  1.  W !!,"This report shows the patient name and prescription information for refills"
  1.  W:JOBN["Tally" !,"that were identified as billable by the patch PSO*7*217"
  1.  W:JOBN["Back" !,"that were back-billed by the patch PSO*7*217"
  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^PSOCPBK4",ZTDESC=JOBN_" copay report" D ^%ZTLOAD K %ZSI W !,"Report queued to print.",! G DONE
  1. START ;
  1.  U IO
  1.  N BLDT,RXO,NAMSP,PSOFILL,PSODFN,PSONAM,PSOOUT,PSODV,RXP,SSN,PSODIV
  1.  N JOBN,PSOPATID
  1.  S NAMSP=$$NAMSP^PSOCPBK3
  1.  S JOBN=$S(^XTMP(NAMSP,0)["BACK":"Back Billing",1:"Tally")
  1.  S PSOOUT=0,PSODV=$S($E(IOST)="C":"C",1:"P")
  1.  S PSOPGCT=0,PSOPGLN=IOSL-7,PSOPGCT=1
  1.  S BLDT=$P($G(^XTMP(NAMSP,0,"LAST")),"^",2)
  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,RXO,Y,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)
  1.  .....D PRTSSN
  1.  .....S RXO=$P($G(^PSRX(RXP,0)),"^")
  1.  .....W ?42," ",RXO," (",PSOFILL,")"
  1.  .....S Y=XX I Y>0 X ^DD("DD")
  1.  .....W ?55," ",Y
  1.  .....W ?69,$S($$PTCOV^IBCNSU3(PSODFN,XX,"PHARMACY"):"YES",1:" NO")
  1.  .....W ?75,$S($$PTCOV^IBCNSU3(PSODFN,BLDT,"PHARMACY"):"YES",1:" NO")
  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*217 -COPAY PRESCRIPTION REFILLS "_JOBN
  1.  S Y=DT X ^DD("DD") W !,"Date printed: ",Y,?70,"Page: ",PSOPGCT,!
  1.  F MJT=1:1:79 W "="
  1.  W !,?69,"INS ON DTE"
  1.  W !,"PATIENT NAME     (SSN)       DIV",?43,"RX# (FILL)",?55,"RELEASE DATE",?69,"REL   BILL"
  1.  W !,"--------------  -------  ----------------",?42,"------------"
  1.  W ?55,"------------",?69,"---- -----"
  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 ?16,"("_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