PSOCPBK4 ;BIR/GN-Copay Back Bill for Automated-release refills cont. ;10/12/05 9:55am
;;7.0;OUTPATIENT PHARMACY;**217,303,460,480**;DEC 1997;Build 35
;External reference to ^PSDRUG supported by DBIA 221
;External reference to ^IBAM(354.7 supported by DBIA 3877
;External reference to $$PTCOV^IBCNSU3 supported by DBIA 4115
;External reference to ^IBARX supported by DBIA 125
;External reference to $$CPTIER^PSNAPIS(P1,P3) supported by DBIA #2531
;External reference to ^DPT supported by DBIA #10035
;External reference to IBARXEU supported by DBIA #10147
;
Q
;
ADDBILL ;add to billable ^XTMP if ok, quit if not
S PSOTRF=PSOTRF+1
S PSOREL=$P($G(^PSRX(RXP,1,YY,0)),"^",18)
Q:'PSOREL ;not released
Q:'YY ;orig fill
Q:+$$RXST^IBARXEU(PSODFN,$P(PSOREL,".")) ;Exempt on Rel dte
;check refill
Q:$P($G(^PSRX(RXP,1,YY,"IB")),"^",1)'="" ;already billed
Q:$P($G(^PSRX(RXP,1,YY,"IB")),"^",2)'="" ;exceeded ann. cap
;
;look for Activity log entry per refill # with the below text
S FOUND=0
F XX=999:0 S XX=$O(^PSRX(RXP,"A",XX),-1) Q:'XX D Q:FOUND
.Q:$P(^PSRX(RXP,"A",XX,0),"^",4)'=YY
.Q:^PSRX(RXP,"A",XX,0)'["External Interface Dispensing is Complete"
.S FOUND=1
Q:'FOUND
;
S ^XTMP(NAMSP,PSODFN,RXP,YY)=$P(PSOREL,".") ;add to XTMP to be bill
Q
;
XTYPE ;
N Y,VADM,I,J,X,SAVY,DFN
S DFN=PSODFN D DEM^VADPT I +$G(VADM(6)) S PSOSCMX="" Q ; DECEASED
S (X,PSOSCMX,SAVY)=""
S J=0 F S J=$O(^PS(59,J)) Q:'J I +$G(^(J,"IB")) S X=+^("IB") Q
I 'X Q
S X=X_"^"_PSODFN D XTYPE^IBARX
I $G(Y)'=1 Q
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
I PSOSCMX="",SAVY=0 S PSOEXMPT=1 Q ; INCOME EXEMPT OR SERVICE-CONNECTED
I PSOSCMX=2 Q ; NEED TO ASK SC QUESTION
Q
;
TOTAL ;
N COUNT,COUNTED
I '$D(PSOVETS) S PSOVETS=0
N I,J
F I=1:1:3 S (PSOCNT("YR2004",I),PSOCNT("YR2005",I))=0
S PSODFN=0 F S PSODFN=$O(^XTMP(NAMSP,PSODFN)) Q:'PSODFN D
.S COUNTED=0
.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
F I=1:1:3 S PSOCNT=PSOCNT+PSOCNT("YR2004",I)+PSOCNT("YR2005",I)
Q
;
BILLIT ;
; IF NO IB NUMBER FOR THIS FILL, SET UP VARIABLES AND TALLY
N PSOCAP,PSODIV,PSODV,PSOFILL,PSOLOG,PSOOUT,PSOPAR,PSOPATID,PSOSITE
N PSOSITE7,PSOSQ,PSOTOT,PSOYEAR,PSOYR,SSN,SAVCPUN,SAVREF
S PSODFN=0
F CC=1:1 S PSODFN=$O(^XTMP(NAMSP,PSODFN)) Q:'PSODFN D Q:STOP
.I CC#100=0,$D(^XTMP(NAMSP,0,"STOP")) D Q
..S $P(^XTMP(NAMSP,0,"LAST"),"^",1,2)="STOP^"_$$NOW^XLFDT,STOP=1
.S (PSOCAP(304),PSOCAP(305))=0 ; INITIAL ANNUAL CAP FOR 2004 & 2005
.F RXP=0:0 S RXP=$O(^XTMP(NAMSP,PSODFN,RXP)) Q:'RXP D
..;calc number of 30-day units eligible to bill
..S (SAVCPUN,PSOCPUN)=($P(^PSRX(RXP,0),"^",8)+29)\30
..F YY=0:0 S YY=$O(^XTMP(NAMSP,PSODFN,RXP,YY)) Q:YY="" D
...S (SAVREF,PSOREF)=YY
...S PSOREL=$G(^XTMP(NAMSP,PSODFN,RXP,YY))
...I PSOCAP($E(PSOREL,1,3)) Q ; MET ANNUAL CAP FOR 2004 OR 2005
...I $P($G(^PSRX(RXP,1,YY,"IB")),"^",1)="" D ; REFILL LEVEL
....D SITE
....D CP^PSOCP ;call back billing
....S PSOCPUN=SAVCPUN,PSOREF=SAVREF
....I $P($G(^PSRX(RXP,1,YY,"IB")),"^",1) D ACCUM ;Do if was billed?
....D CP I +$G(PSOREF) D ACCUM
Q
;
CP ; Entry point to Check if COPAY - Requires RXP,PSOSITE7
I '$D(PSOPAR) D ^PSOLSET G CP
K PSOCP
S PSOCPN=$P(^PSRX(RXP,0),"^",2) ; Set COPAY dfn PTR TO PATIENT
S PSOCP=$P($G(^PSRX(RXP,"IB")),"^") ; IB action type
S PSOSAVE=$S(PSOCP:1,1:"") ; save current copay status
; Set x=service^dfn^actiontype^user duz
I +$G(PSOSITE7)'>0 S PSOSITE7=$P(^PS(59,PSOSITE,"IB"),"^")
S X=PSOSITE7_"^"_PSOCPN_"^"_PSOCP_"^"_$P(^PSRX(RXP,0),"^",16)
;
RX ; Determine Original or Refill for RX
N PSOIB
S PSOIB=0
S PSOREF=0
;set refill number if this is a refill
I $G(^PSRX(RXP,1,+$G(YY),0))]"" S PSOREF=YY
;
;Orig fill -check if bill # already exists
I 'PSOREF,+$P($G(^PSRX(RXP,"IB")),"^",2)>0 D CHKIB^PSOCP1
I PSOIB D QUIT Q
;already attempted to bill, but exceeded Anuual Cap
I 'PSOREF,+$P($G(^PSRX(RXP,"IB")),"^",4)>0 D QUIT Q
;
;Refill -check if bill # already exists
I PSOREF,+$G(^PSRX(RXP,1,PSOREF,"IB")) D CHKIB^PSOCP1
I PSOIB D QUIT Q
;already attempted to bill, but exceeded Anuual Cap
I PSOREF,+$P($G(^PSRX(RXP,1,PSOREF,"IB")),"^",2) G QUIT
;
;set temporary variable to copay and then look for exceptions
S PSOCHG=1
D COPAYREL
I 'PSOCHG D QUIT Q ;not billable
I PSOCHG=2,'PSOCP D QUIT
Q
QUIT ;
K Y,PSOCP1,PSOREF,PSOCPUN,PSOCP2,PSOCPN,X,PSOCHG,PSOSAVE,PREA,PSORSN,PSOCOMM,PSOOLD,PSONW,PSODA
Q
;
COPAYREL ; Recheck copay status at release
;
; check Rx patient status
I $P(^PSRX(RXP,0),"^",3)'="",$P($G(^PS(53,$P(^PSRX(RXP,0),"^",3),0)),"^",7)=1 S PSOCHG=0 Q
; see if drug is nutritional supplement, investigational or supply
N DRG,DRGTYP,PSOEXMPT
S DRG=+$P(^PSRX(RXP,0),"^",6),DRGTYP=$P($G(^PSDRUG(DRG,0)),"^",3)
I DRGTYP["I"!(DRGTYP["S")!(DRGTYP["N") S PSOCHG=0,PSOEXMPT=1 Q
K PSOTG,CHKXTYPE
I +$G(^PSRX(RXP,"IBQ")) D XTYPE1^PSOCP1
I $G(^PSRX(RXP,"IBQ"))["1" S PSOCHG=0 Q
;***** begin - for regression test - sites must not use this as it will adversely affect billing results - only used by SQA
; The following is required for testing different effective dates. If date is less than 02/27/17 bills old way. Otherwise bills new way.
;S ^XTMP("PSOTIEREFTST",0)="3201231^3170227^FOR SQA TESTING ONLY" - Defined for SQA testing only. Delete this XTMP when regression complete
D NOW^%DTC N PSOTIERE
S PSOTIERE=1 ;use copay tiers - new
I $P(%,".")<3170227 S PSOTIERE=0 ;legacy billing - old
I $G(^XTMP("PSOTIEREFTST",0)) S PSOTIERE=1 ;for SQA testing only - bill with copay tiers - new
;***** end for regression test
G COPAYRE1:'PSOTIERE
; check copay tier. Tier zero does not have copay charges
N CPDATE,X,PSOCPT D NOW^%DTC S CPDATE=X S PSOCPT=$$CPTIER^PSNAPIS("",CPDATE,DRG) K CPDATE,X
I $P(PSOCPT,"^")=0 S PSOCHG=0 Q ;Tier zero do not send to IB for copay charge
I '$G(PSOEXMPT),$P(PSOCPT,"^")'=0 S PSOCOMM="",PSOOLD="No Copay",PSONW="Copay" S PSODA=RXP,PREA="R" D ACTLOG^PSOCPA
COPAYRE1 ;
Q
;
ACCUM ; ACCUMULATE TOTALS AND SEE IF PATIENT MET ANNUAL CAP
S PSOYR=$E(PSOREL,1,3) I PSOYR="" Q
S PSOYEAR=$S(PSOYR="304":"YR2004",PSOYR="305":"YR2005",1:"")
Q:PSOYEAR=""
;
;get Xtmp billing amt which would be IBAM tot + any previous refills
S PSOTOT=$G(^XTMP(NAMSP,PSODFN,PSOYEAR))
;
;if none yet then init to the IBAM total for the year
I 'PSOTOT D
.F PSOSQ=0:0 S PSOSQ=$O(^IBAM(354.7,PSODFN,1,PSOSQ)) Q:'PSOSQ D
..S PSOLOG=$G(^IBAM(354.7,PSODFN,1,PSOSQ,0))
..I $E(PSOLOG,1,3)=PSOYR S PSOTOT=PSOTOT+$P(PSOLOG,"^",2)
;
;update Xtmp tot nodes with current refill amounts
S ^XTMP(NAMSP,PSODFN,PSOYEAR)=PSOTOT+(PSOCPUN*7)
S ^XTMP(NAMSP,PSODFN,PSOYEAR,PSOCPUN)=$G(^XTMP(NAMSP,PSODFN,PSOYEAR,PSOCPUN))+1
;
;indicate this refill may be billable or (was billed, if BILLING run)
;by adding to Xtmp "BILLED"
N PSONAM
S PSONAM=$P($G(^DPT(PSODFN,0)),"^"),PSONAM=$P(PSONAM,",")
S PSONAM=$E(PSONAM,1,6)
S ^XTMP(NAMSP,"BILLED",PSONAM,PSODFN,RXP,PSOREF)=PSOREL
Q
;
SITE ; SET UP VARIABLES NEEDED BY BILLING
S PSOSITE=$S(YY=0:$P(^PSRX(RXP,2),"^",9),1:$P($G(^PSRX(RXP,1,YY,0)),"^",9))
Q:PSOSITE=""
S PSOPAR=$G(^PS(59,PSOSITE,1))
S PSOSITE7=$P($G(^PS(59,PSOSITE,"IB")),"^")
Q
;
RPT ;
N JOBN,NAMSP,ZTDESC,ZTRTN
S NAMSP=$$NAMSP^PSOCPBK3
S JOBN=$S(^XTMP(NAMSP,0)["BACK":"Back Billing",1:"Tally")
L +^XTMP(NAMSP):0 I '$T D Q
.W !,JOBN_" job for PSO*7*217 is still running. Halting..."
L -^XTMP(NAMSP)
W !!,"This report shows the patient name and prescription information for refills"
W:JOBN["Tally" !,"that were identified as billable by the patch PSO*7*217"
W:JOBN["Back" !,"that were back-billed by the patch PSO*7*217"
W !!,"You may queue the report to print, if you wish.",!
;
DVC K %ZIS,POP,IOP S %ZIS="QM" D ^%ZIS I $G(POP) W !!,"Nothing queued to print.",! G DONE
QUEUE I $D(IO("Q")) S ZTRTN="START^PSOCPBK4",ZTDESC=JOBN_" copay report" D ^%ZTLOAD K %ZSI W !,"Report queued to print.",! G DONE
START ;
U IO
N BLDT,RXO,NAMSP,PSOFILL,PSODFN,PSONAM,PSOOUT,PSODV,RXP,SSN,PSODIV
N JOBN,PSOPATID
S NAMSP=$$NAMSP^PSOCPBK3
S JOBN=$S(^XTMP(NAMSP,0)["BACK":"Back Billing",1:"Tally")
S PSOOUT=0,PSODV=$S($E(IOST)="C":"C",1:"P")
S PSOPGCT=0,PSOPGLN=IOSL-7,PSOPGCT=1
S BLDT=$P($G(^XTMP(NAMSP,0,"LAST")),"^",2)
D TITLE
S PSONAM=""
F S PSONAM=$O(^XTMP(NAMSP,"BILLED",PSONAM)) Q:PSONAM="" D
.S PSODFN=""
.F S PSODFN=$O(^XTMP(NAMSP,"BILLED",PSONAM,PSODFN)) Q:PSODFN="" D
..S RXP=""
..F S RXP=$O(^XTMP(NAMSP,"BILLED",PSONAM,PSODFN,RXP)) Q:RXP="" D
...S PSOFILL=""
...F S PSOFILL=$O(^XTMP(NAMSP,"BILLED",PSONAM,PSODFN,RXP,PSOFILL)) Q:PSOFILL="" D
....N XX,RXO,Y,PSONAME
....S XX=$G(^XTMP(NAMSP,"BILLED",PSONAM,PSODFN,RXP,PSOFILL)) D
.....D FULL Q:$G(PSOOUT) S PSONAME=$P($G(^DPT(PSODFN,0)),"^")
.....W !,$E(PSONAME,1,14)
.....D PRTSSN
.....S RXO=$P($G(^PSRX(RXP,0)),"^")
.....W ?42," ",RXO," (",PSOFILL,")"
.....S Y=XX I Y>0 X ^DD("DD")
.....W ?55," ",Y
.....W ?69,$S($$PTCOV^IBCNSU3(PSODFN,XX,"PHARMACY"):"YES",1:" NO")
.....W ?75,$S($$PTCOV^IBCNSU3(PSODFN,BLDT,"PHARMACY"):"YES",1:" NO")
G END
;
FULL ;
I ($Y+7)>IOSL&('$G(PSOOUT)) D TITLE
Q
;
TITLE ;
I $G(PSODV)="C",$G(PSOPGCT)'=1 W ! K DIR S DIR(0)="E" D ^DIR K DIR I 'Y S PSOOUT=1 Q
;
W @IOF D
. W !,"Patch PSO*7*217 -COPAY PRESCRIPTION REFILLS "_JOBN
S Y=DT X ^DD("DD") W !,"Date printed: ",Y,?70,"Page: ",PSOPGCT,!
F MJT=1:1:79 W "="
W !,?69,"INS ON DTE"
W !,"PATIENT NAME (SSN) DIV",?43,"RX# (FILL)",?55,"RELEASE DATE",?69,"REL BILL"
W !,"-------------- ------- ----------------",?42,"------------"
W ?55,"------------",?69,"---- -----"
S PSOPGCT=PSOPGCT+1
Q
END ;
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
I $G(PSODV)="C" W !
E W @IOF
DONE ;
K MJT,PSOPGCT,PSOPGLN,Y,DIR,X,IOP,POP,IO("Q"),DIRUT,DUOUT,DTOUT
D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
Q
;
PRTSSN ;
S SSN=$P(^DPT(PSODFN,0),"^",9),SSN=$E(SSN,$L(SSN)-3,$L(SSN))
S PSOPATID=$E(PSONAM,1)_SSN
S PSODIV=$P($G(^PSRX(RXP,2)),"^",9)
S:PSODIV'="" PSODIV=$P($G(^PS(59,PSODIV,0)),"^",1)
W ?16,"("_PSOPATID_")"_" "_PSODIV
Q
;
ETIME(SECTIME) ;convert seconds to day:hr:min:sec
N DAY,HR,MIN,SEC,ETIM
S (DAY,HR,MIN,SEC)=""
I SECTIME>86400 S DAY=SECTIME\86400,SECTIME=SECTIME#86400
I SECTIME>3600 S HR=SECTIME\3600,SECTIME=SECTIME#3600
I SECTIME>60 S MIN=SECTIME\60,SECTIME=SECTIME#60
S SEC=SECTIME
S ETIM=""
S:$L(HR)=1 HR=0_HR S:$L(MIN)=1 MIN=0_MIN S:$L(SEC)=1 SEC=0_SEC
S:DAY ETIM=DAY_" Day " S:HR ETIM=ETIM_HR_":" S:MIN ETIM=ETIM_MIN
S ETIM=ETIM_":"_SEC
Q ETIM
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOCPBK4 11008 printed Sep 23, 2025@20:02:03 Page 2
PSOCPBK4 ;BIR/GN-Copay Back Bill for Automated-release refills cont. ;10/12/05 9:55am
+1 ;;7.0;OUTPATIENT PHARMACY;**217,303,460,480**;DEC 1997;Build 35
+2 ;External reference to ^PSDRUG supported by DBIA 221
+3 ;External reference to ^IBAM(354.7 supported by DBIA 3877
+4 ;External reference to $$PTCOV^IBCNSU3 supported by DBIA 4115
+5 ;External reference to ^IBARX supported by DBIA 125
+6 ;External reference to $$CPTIER^PSNAPIS(P1,P3) supported by DBIA #2531
+7 ;External reference to ^DPT supported by DBIA #10035
+8 ;External reference to IBARXEU supported by DBIA #10147
+9 ;
+10 QUIT
+11 ;
ADDBILL ;add to billable ^XTMP if ok, quit if not
+1 SET PSOTRF=PSOTRF+1
+2 SET PSOREL=$PIECE($GET(^PSRX(RXP,1,YY,0)),"^",18)
+3 ;not released
if 'PSOREL
QUIT
+4 ;orig fill
if 'YY
QUIT
+5 ;Exempt on Rel dte
if +$$RXST^IBARXEU(PSODFN,$PIECE(PSOREL,"."))
QUIT
+6 ;check refill
+7 ;already billed
if $PIECE($GET(^PSRX(RXP,1,YY,"IB")),"^",1)'=""
QUIT
+8 ;exceeded ann. cap
if $PIECE($GET(^PSRX(RXP,1,YY,"IB")),"^",2)'=""
QUIT
+9 ;
+10 ;look for Activity log entry per refill # with the below text
+11 SET FOUND=0
+12 FOR XX=999:0
SET XX=$ORDER(^PSRX(RXP,"A",XX),-1)
if 'XX
QUIT
Begin DoDot:1
+13 if $PIECE(^PSRX(RXP,"A",XX,0),"^",4)'=YY
QUIT
+14 if ^PSRX(RXP,"A",XX,0)'["External Interface Dispensing is Complete"
QUIT
+15 SET FOUND=1
End DoDot:1
if FOUND
QUIT
+16 if 'FOUND
QUIT
+17 ;
+18 ;add to XTMP to be bill
SET ^XTMP(NAMSP,PSODFN,RXP,YY)=$PIECE(PSOREL,".")
+19 QUIT
+20 ;
XTYPE ;
+1 NEW Y,VADM,I,J,X,SAVY,DFN
+2 ; DECEASED
SET DFN=PSODFN
DO DEM^VADPT
IF +$GET(VADM(6))
SET PSOSCMX=""
QUIT
+3 SET (X,PSOSCMX,SAVY)=""
+4 SET J=0
FOR
SET J=$ORDER(^PS(59,J))
if 'J
QUIT
IF +$GET(^(J,"IB"))
SET X=+^("IB")
QUIT
+5 IF 'X
QUIT
+6 SET X=X_"^"_PSODFN
DO XTYPE^IBARX
+7 IF $GET(Y)'=1
QUIT
+8 SET J=""
FOR
SET J=$ORDER(Y(J))
if 'J
QUIT
SET I=""
FOR
SET SAVY=I
SET I=$ORDER(Y(J,I))
if I=""
QUIT
if I>0
SET PSOSCMX=I
+9 ; INCOME EXEMPT OR SERVICE-CONNECTED
IF PSOSCMX=""
IF SAVY=0
SET PSOEXMPT=1
QUIT
+10 ; NEED TO ASK SC QUESTION
IF PSOSCMX=2
QUIT
+11 QUIT
+12 ;
TOTAL ;
+1 NEW COUNT,COUNTED
+2 IF '$DATA(PSOVETS)
SET PSOVETS=0
+3 NEW I,J
+4 FOR I=1:1:3
SET (PSOCNT("YR2004",I),PSOCNT("YR2005",I))=0
+5 SET PSODFN=0
FOR
SET PSODFN=$ORDER(^XTMP(NAMSP,PSODFN))
if 'PSODFN
QUIT
Begin DoDot:1
+6 SET COUNTED=0
+7 FOR J="YR2004","YR2005"
FOR I=1:1:3
SET COUNT=$GET(^XTMP(NAMSP,PSODFN,J,I))
IF COUNT>0
if '$GET(COUNTED)
SET COUNTED=1
SET PSOVETS=PSOVETS+1
SET PSOCNT(J,I)=PSOCNT(J,I)+COUNT
End DoDot:1
+8 FOR I=1:1:3
SET PSOCNT=PSOCNT+PSOCNT("YR2004",I)+PSOCNT("YR2005",I)
+9 QUIT
+10 ;
BILLIT ;
+1 ; IF NO IB NUMBER FOR THIS FILL, SET UP VARIABLES AND TALLY
+2 NEW PSOCAP,PSODIV,PSODV,PSOFILL,PSOLOG,PSOOUT,PSOPAR,PSOPATID,PSOSITE
+3 NEW PSOSITE7,PSOSQ,PSOTOT,PSOYEAR,PSOYR,SSN,SAVCPUN,SAVREF
+4 SET PSODFN=0
+5 FOR CC=1:1
SET PSODFN=$ORDER(^XTMP(NAMSP,PSODFN))
if 'PSODFN
QUIT
Begin DoDot:1
+6 IF CC#100=0
IF $DATA(^XTMP(NAMSP,0,"STOP"))
Begin DoDot:2
+7 SET $PIECE(^XTMP(NAMSP,0,"LAST"),"^",1,2)="STOP^"_$$NOW^XLFDT
SET STOP=1
End DoDot:2
QUIT
+8 ; INITIAL ANNUAL CAP FOR 2004 & 2005
SET (PSOCAP(304),PSOCAP(305))=0
+9 FOR RXP=0:0
SET RXP=$ORDER(^XTMP(NAMSP,PSODFN,RXP))
if 'RXP
QUIT
Begin DoDot:2
+10 ;calc number of 30-day units eligible to bill
+11 SET (SAVCPUN,PSOCPUN)=($PIECE(^PSRX(RXP,0),"^",8)+29)\30
+12 FOR YY=0:0
SET YY=$ORDER(^XTMP(NAMSP,PSODFN,RXP,YY))
if YY=""
QUIT
Begin DoDot:3
+13 SET (SAVREF,PSOREF)=YY
+14 SET PSOREL=$GET(^XTMP(NAMSP,PSODFN,RXP,YY))
+15 ; MET ANNUAL CAP FOR 2004 OR 2005
IF PSOCAP($EXTRACT(PSOREL,1,3))
QUIT
+16 ; REFILL LEVEL
IF $PIECE($GET(^PSRX(RXP,1,YY,"IB")),"^",1)=""
Begin DoDot:4
+17 DO SITE
+18 ;call back billing
DO CP^PSOCP
+19 SET PSOCPUN=SAVCPUN
SET PSOREF=SAVREF
+20 ;Do if was billed?
IF $PIECE($GET(^PSRX(RXP,1,YY,"IB")),"^",1)
DO ACCUM
+21 DO CP
IF +$GET(PSOREF)
DO ACCUM
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
if STOP
QUIT
+22 QUIT
+23 ;
CP ; Entry point to Check if COPAY - Requires RXP,PSOSITE7
+1 IF '$DATA(PSOPAR)
DO ^PSOLSET
GOTO CP
+2 KILL PSOCP
+3 ; Set COPAY dfn PTR TO PATIENT
SET PSOCPN=$PIECE(^PSRX(RXP,0),"^",2)
+4 ; IB action type
SET PSOCP=$PIECE($GET(^PSRX(RXP,"IB")),"^")
+5 ; save current copay status
SET PSOSAVE=$SELECT(PSOCP:1,1:"")
+6 ; Set x=service^dfn^actiontype^user duz
+7 IF +$GET(PSOSITE7)'>0
SET PSOSITE7=$PIECE(^PS(59,PSOSITE,"IB"),"^")
+8 SET X=PSOSITE7_"^"_PSOCPN_"^"_PSOCP_"^"_$PIECE(^PSRX(RXP,0),"^",16)
+9 ;
RX ; Determine Original or Refill for RX
+1 NEW PSOIB
+2 SET PSOIB=0
+3 SET PSOREF=0
+4 ;set refill number if this is a refill
+5 IF $GET(^PSRX(RXP,1,+$GET(YY),0))]""
SET PSOREF=YY
+6 ;
+7 ;Orig fill -check if bill # already exists
+8 IF 'PSOREF
IF +$PIECE($GET(^PSRX(RXP,"IB")),"^",2)>0
DO CHKIB^PSOCP1
+9 IF PSOIB
DO QUIT
QUIT
+10 ;already attempted to bill, but exceeded Anuual Cap
+11 IF 'PSOREF
IF +$PIECE($GET(^PSRX(RXP,"IB")),"^",4)>0
DO QUIT
QUIT
+12 ;
+13 ;Refill -check if bill # already exists
+14 IF PSOREF
IF +$GET(^PSRX(RXP,1,PSOREF,"IB"))
DO CHKIB^PSOCP1
+15 IF PSOIB
DO QUIT
QUIT
+16 ;already attempted to bill, but exceeded Anuual Cap
+17 IF PSOREF
IF +$PIECE($GET(^PSRX(RXP,1,PSOREF,"IB")),"^",2)
GOTO QUIT
+18 ;
+19 ;set temporary variable to copay and then look for exceptions
+20 SET PSOCHG=1
+21 DO COPAYREL
+22 ;not billable
IF 'PSOCHG
DO QUIT
QUIT
+23 IF PSOCHG=2
IF 'PSOCP
DO QUIT
+24 QUIT
QUIT ;
+1 KILL Y,PSOCP1,PSOREF,PSOCPUN,PSOCP2,PSOCPN,X,PSOCHG,PSOSAVE,PREA,PSORSN,PSOCOMM,PSOOLD,PSONW,PSODA
+2 QUIT
+3 ;
COPAYREL ; Recheck copay status at release
+1 ;
+2 ; check Rx patient status
+3 IF $PIECE(^PSRX(RXP,0),"^",3)'=""
IF $PIECE($GET(^PS(53,$PIECE(^PSRX(RXP,0),"^",3),0)),"^",7)=1
SET PSOCHG=0
QUIT
+4 ; see if drug is nutritional supplement, investigational or supply
+5 NEW DRG,DRGTYP,PSOEXMPT
+6 SET DRG=+$PIECE(^PSRX(RXP,0),"^",6)
SET DRGTYP=$PIECE($GET(^PSDRUG(DRG,0)),"^",3)
+7 IF DRGTYP["I"!(DRGTYP["S")!(DRGTYP["N")
SET PSOCHG=0
SET PSOEXMPT=1
QUIT
+8 KILL PSOTG,CHKXTYPE
+9 IF +$GET(^PSRX(RXP,"IBQ"))
DO XTYPE1^PSOCP1
+10 IF $GET(^PSRX(RXP,"IBQ"))["1"
SET PSOCHG=0
QUIT
+11 ;***** begin - for regression test - sites must not use this as it will adversely affect billing results - only used by SQA
+12 ; The following is required for testing different effective dates. If date is less than 02/27/17 bills old way. Otherwise bills new way.
+13 ;S ^XTMP("PSOTIEREFTST",0)="3201231^3170227^FOR SQA TESTING ONLY" - Defined for SQA testing only. Delete this XTMP when regression complete
+14 DO NOW^%DTC
NEW PSOTIERE
+15 ;use copay tiers - new
SET PSOTIERE=1
+16 ;legacy billing - old
IF $PIECE(%,".")<3170227
SET PSOTIERE=0
+17 ;for SQA testing only - bill with copay tiers - new
IF $GET(^XTMP("PSOTIEREFTST",0))
SET PSOTIERE=1
+18 ;***** end for regression test
+19 if 'PSOTIERE
GOTO COPAYRE1
+20 ; check copay tier. Tier zero does not have copay charges
+21 NEW CPDATE,X,PSOCPT
DO NOW^%DTC
SET CPDATE=X
SET PSOCPT=$$CPTIER^PSNAPIS("",CPDATE,DRG)
KILL CPDATE,X
+22 ;Tier zero do not send to IB for copay charge
IF $PIECE(PSOCPT,"^")=0
SET PSOCHG=0
QUIT
+23 IF '$GET(PSOEXMPT)
IF $PIECE(PSOCPT,"^")'=0
SET PSOCOMM=""
SET PSOOLD="No Copay"
SET PSONW="Copay"
SET PSODA=RXP
SET PREA="R"
DO ACTLOG^PSOCPA
COPAYRE1 ;
+1 QUIT
+2 ;
ACCUM ; ACCUMULATE TOTALS AND SEE IF PATIENT MET ANNUAL CAP
+1 SET PSOYR=$EXTRACT(PSOREL,1,3)
IF PSOYR=""
QUIT
+2 SET PSOYEAR=$SELECT(PSOYR="304":"YR2004",PSOYR="305":"YR2005",1:"")
+3 if PSOYEAR=""
QUIT
+4 ;
+5 ;get Xtmp billing amt which would be IBAM tot + any previous refills
+6 SET PSOTOT=$GET(^XTMP(NAMSP,PSODFN,PSOYEAR))
+7 ;
+8 ;if none yet then init to the IBAM total for the year
+9 IF 'PSOTOT
Begin DoDot:1
+10 FOR PSOSQ=0:0
SET PSOSQ=$ORDER(^IBAM(354.7,PSODFN,1,PSOSQ))
if 'PSOSQ
QUIT
Begin DoDot:2
+11 SET PSOLOG=$GET(^IBAM(354.7,PSODFN,1,PSOSQ,0))
+12 IF $EXTRACT(PSOLOG,1,3)=PSOYR
SET PSOTOT=PSOTOT+$PIECE(PSOLOG,"^",2)
End DoDot:2
End DoDot:1
+13 ;
+14 ;update Xtmp tot nodes with current refill amounts
+15 SET ^XTMP(NAMSP,PSODFN,PSOYEAR)=PSOTOT+(PSOCPUN*7)
+16 SET ^XTMP(NAMSP,PSODFN,PSOYEAR,PSOCPUN)=$GET(^XTMP(NAMSP,PSODFN,PSOYEAR,PSOCPUN))+1
+17 ;
+18 ;indicate this refill may be billable or (was billed, if BILLING run)
+19 ;by adding to Xtmp "BILLED"
+20 NEW PSONAM
+21 SET PSONAM=$PIECE($GET(^DPT(PSODFN,0)),"^")
SET PSONAM=$PIECE(PSONAM,",")
+22 SET PSONAM=$EXTRACT(PSONAM,1,6)
+23 SET ^XTMP(NAMSP,"BILLED",PSONAM,PSODFN,RXP,PSOREF)=PSOREL
+24 QUIT
+25 ;
SITE ; SET UP VARIABLES NEEDED BY BILLING
+1 SET PSOSITE=$SELECT(YY=0:$PIECE(^PSRX(RXP,2),"^",9),1:$PIECE($GET(^PSRX(RXP,1,YY,0)),"^",9))
+2 if PSOSITE=""
QUIT
+3 SET PSOPAR=$GET(^PS(59,PSOSITE,1))
+4 SET PSOSITE7=$PIECE($GET(^PS(59,PSOSITE,"IB")),"^")
+5 QUIT
+6 ;
RPT ;
+1 NEW JOBN,NAMSP,ZTDESC,ZTRTN
+2 SET NAMSP=$$NAMSP^PSOCPBK3
+3 SET JOBN=$SELECT(^XTMP(NAMSP,0)["BACK":"Back Billing",1:"Tally")
+4 LOCK +^XTMP(NAMSP):0
IF '$TEST
Begin DoDot:1
+5 WRITE !,JOBN_" job for PSO*7*217 is still running. Halting..."
End DoDot:1
QUIT
+6 LOCK -^XTMP(NAMSP)
+7 WRITE !!,"This report shows the patient name and prescription information for refills"
+8 if JOBN["Tally"
WRITE !,"that were identified as billable by the patch PSO*7*217"
+9 if JOBN["Back"
WRITE !,"that were back-billed by the patch PSO*7*217"
+10 WRITE !!,"You may queue the report to print, if you wish.",!
+11 ;
DVC KILL %ZIS,POP,IOP
SET %ZIS="QM"
DO ^%ZIS
IF $GET(POP)
WRITE !!,"Nothing queued to print.",!
GOTO DONE
QUEUE IF $DATA(IO("Q"))
SET ZTRTN="START^PSOCPBK4"
SET ZTDESC=JOBN_" copay report"
DO ^%ZTLOAD
KILL %ZSI
WRITE !,"Report queued to print.",!
GOTO DONE
START ;
+1 USE IO
+2 NEW BLDT,RXO,NAMSP,PSOFILL,PSODFN,PSONAM,PSOOUT,PSODV,RXP,SSN,PSODIV
+3 NEW JOBN,PSOPATID
+4 SET NAMSP=$$NAMSP^PSOCPBK3
+5 SET JOBN=$SELECT(^XTMP(NAMSP,0)["BACK":"Back Billing",1:"Tally")
+6 SET PSOOUT=0
SET PSODV=$SELECT($EXTRACT(IOST)="C":"C",1:"P")
+7 SET PSOPGCT=0
SET PSOPGLN=IOSL-7
SET PSOPGCT=1
+8 SET BLDT=$PIECE($GET(^XTMP(NAMSP,0,"LAST")),"^",2)
+9 DO TITLE
+10 SET PSONAM=""
+11 FOR
SET PSONAM=$ORDER(^XTMP(NAMSP,"BILLED",PSONAM))
if PSONAM=""
QUIT
Begin DoDot:1
+12 SET PSODFN=""
+13 FOR
SET PSODFN=$ORDER(^XTMP(NAMSP,"BILLED",PSONAM,PSODFN))
if PSODFN=""
QUIT
Begin DoDot:2
+14 SET RXP=""
+15 FOR
SET RXP=$ORDER(^XTMP(NAMSP,"BILLED",PSONAM,PSODFN,RXP))
if RXP=""
QUIT
Begin DoDot:3
+16 SET PSOFILL=""
+17 FOR
SET PSOFILL=$ORDER(^XTMP(NAMSP,"BILLED",PSONAM,PSODFN,RXP,PSOFILL))
if PSOFILL=""
QUIT
Begin DoDot:4
+18 NEW XX,RXO,Y,PSONAME
+19 SET XX=$GET(^XTMP(NAMSP,"BILLED",PSONAM,PSODFN,RXP,PSOFILL))
Begin DoDot:5
+20 DO FULL
if $GET(PSOOUT)
QUIT
SET PSONAME=$PIECE($GET(^DPT(PSODFN,0)),"^")
+21 WRITE !,$EXTRACT(PSONAME,1,14)
+22 DO PRTSSN
+23 SET RXO=$PIECE($GET(^PSRX(RXP,0)),"^")
+24 WRITE ?42," ",RXO," (",PSOFILL,")"
+25 SET Y=XX
IF Y>0
XECUTE ^DD("DD")
+26 WRITE ?55," ",Y
+27 WRITE ?69,$SELECT($$PTCOV^IBCNSU3(PSODFN,XX,"PHARMACY"):"YES",1:" NO")
+28 WRITE ?75,$SELECT($$PTCOV^IBCNSU3(PSODFN,BLDT,"PHARMACY"):"YES",1:" NO")
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+29 GOTO END
+30 ;
FULL ;
+1 IF ($Y+7)>IOSL&('$GET(PSOOUT))
DO TITLE
+2 QUIT
+3 ;
TITLE ;
+1 IF $GET(PSODV)="C"
IF $GET(PSOPGCT)'=1
WRITE !
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF 'Y
SET PSOOUT=1
QUIT
+2 ;
+3 WRITE @IOF
Begin DoDot:1
+4 WRITE !,"Patch PSO*7*217 -COPAY PRESCRIPTION REFILLS "_JOBN
End DoDot:1
+5 SET Y=DT
XECUTE ^DD("DD")
WRITE !,"Date printed: ",Y,?70,"Page: ",PSOPGCT,!
+6 FOR MJT=1:1:79
WRITE "="
+7 WRITE !,?69,"INS ON DTE"
+8 WRITE !,"PATIENT NAME (SSN) DIV",?43,"RX# (FILL)",?55,"RELEASE DATE",?69,"REL BILL"
+9 WRITE !,"-------------- ------- ----------------",?42,"------------"
+10 WRITE ?55,"------------",?69,"---- -----"
+11 SET PSOPGCT=PSOPGCT+1
+12 QUIT
END ;
+1 IF '$GET(PSOOUT)
IF $GET(PSODV)="C"
WRITE !!,"** End of Report **"
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to continue"
DO ^DIR
KILL DIR
+2 IF $GET(PSODV)="C"
WRITE !
+3 IF '$TEST
WRITE @IOF
DONE ;
+1 KILL MJT,PSOPGCT,PSOPGLN,Y,DIR,X,IOP,POP,IO("Q"),DIRUT,DUOUT,DTOUT
+2 DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+3 QUIT
+4 ;
PRTSSN ;
+1 SET SSN=$PIECE(^DPT(PSODFN,0),"^",9)
SET SSN=$EXTRACT(SSN,$LENGTH(SSN)-3,$LENGTH(SSN))
+2 SET PSOPATID=$EXTRACT(PSONAM,1)_SSN
+3 SET PSODIV=$PIECE($GET(^PSRX(RXP,2)),"^",9)
+4 if PSODIV'=""
SET PSODIV=$PIECE($GET(^PS(59,PSODIV,0)),"^",1)
+5 WRITE ?16,"("_PSOPATID_")"_" "_PSODIV
+6 QUIT
+7 ;
ETIME(SECTIME) ;convert seconds to day:hr:min:sec
+1 NEW DAY,HR,MIN,SEC,ETIM
+2 SET (DAY,HR,MIN,SEC)=""
+3 IF SECTIME>86400
SET DAY=SECTIME\86400
SET SECTIME=SECTIME#86400
+4 IF SECTIME>3600
SET HR=SECTIME\3600
SET SECTIME=SECTIME#3600
+5 IF SECTIME>60
SET MIN=SECTIME\60
SET SECTIME=SECTIME#60
+6 SET SEC=SECTIME
+7 SET ETIM=""
+8 if $LENGTH(HR)=1
SET HR=0_HR
if $LENGTH(MIN)=1
SET MIN=0_MIN
if $LENGTH(SEC)=1
SET SEC=0_SEC
+9 if DAY
SET ETIM=DAY_" Day "
if HR
SET ETIM=ETIM_HR_":"
if MIN
SET ETIM=ETIM_MIN
+10 SET ETIM=ETIM_":"_SEC
+11 QUIT ETIM
