PSOCPBK2 ;BIR/EJW,GN-Tally Automated-release refill copay cont. ;8/10/05 12:03pm
;;7.0;OUTPATIENT PHARMACY;**215,303**;DEC 1997;Build 19
;External reference to ^PSDRUG supported by DBIA 221
;External reference to ^IBAM(354.7 supported by DBIA 3877
;External reference to $$PROD^XUPROD(1) supported by DBIA 4440
;
TALLY ;
; 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
S PSODFN=0
F QQ=1:1 S PSODFN=$O(^XTMP(NAMSP,PSODFN)) Q:'PSODFN D Q:STOP
.I QQ#100=0,$D(^XTMP(NAMSP,0,"STOP")) K ^XTMP(NAMSP) S 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
..F YY=0:0 S YY=$O(^XTMP(NAMSP,PSODFN,RXP,YY)) Q:YY="" D
...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
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 G QUIT
;already attempted to bill, but exceeded Anuual Cap
I 'PSOREF,+$P($G(^PSRX(RXP,"IB")),"^",4)>0 G QUIT
;
;Refill -check if bill # already exists
I PSOREF,+$G(^PSRX(RXP,1,PSOREF,"IB")) D CHKIB^PSOCP1
I PSOIB G QUIT
;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 G QUIT ;not billable
I PSOCHG=2 I 'PSOCP G QUIT
; Units for COPAY
;calc number of 30-day units eligible to bill
S PSOCPUN=($P(^PSRX(RXP,0),"^",8)+29)\30
D ACCUM
QUIT ;
K Y,PSOCP1,PSOCP2,PSOCPN,X,PSOCPUN,PSOREF,PSOCHG,PSOSAVE,PREA,PSORSN
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
S DRG=+$P(^PSRX(RXP,0),"^",6),DRGTYP=$P($G(^PSDRUG(DRG,0)),"^",3)
I DRGTYP["I"!(DRGTYP["S")!(DRGTYP["N") S PSOCHG=0 Q
K PSOTG,CHKXTYPE
I +$G(^PSRX(RXP,"IBQ")) D XTYPE1^PSOCP1
I $G(^PSRX(RXP,"IBQ"))["1" S PSOCHG=0 Q
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 yegt 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)
;
;see if current refill added to tot exceeds annual cap and quit
I PSOTOT+(7*PSOCPUN)>840 S PSOCAP(PSOYR)=1 Q
;
;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 would be billable 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 NAMSP S NAMSP=$$NAMSP^PSOCPBK1
L +^XTMP(NAMSP):0 I '$T D Q
. W !,"Copay Tally job for PSO*7*215 is still running. Halting..."
L -^XTMP(NAMSP)
W !!,"This report shows the patient name and prescription information for refills"
W !,"that were indentified as billable by the tally patch PSO*7*215"
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^PSOCPBK2",ZTDESC="Potential Billable copay report" D ^%ZTLOAD K %ZSI W !,"Report queued to print.",! G DONE
START ;
U IO
N NAMSP S NAMSP=$$NAMSP^PSOCPBK1
S PSOOUT=0,PSODV=$S($E(IOST)="C":"C",1:"P")
S PSOPGCT=0,PSOPGLN=IOSL-7,PSOPGCT=1
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,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
.....W ?46," ",RXP," (",PSOFILL,")" D
......S Y=XX I Y>0 X ^DD("DD")
......W ?65," ",Y
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*215 -COPAY PRESCRIPTION REFILLS BILLABLE"
S Y=DT X ^DD("DD") W !,"Date printed: ",Y,?70,"Page: ",PSOPGCT,!
F MJT=1:1:79 W "="
W !,"PATIENT NAME (SSN) DIV",?48,"RX# (FILL)",?66,"RELEASE DATE"
W !,"-------------- ------- ----------------",?47,"------------"
W ?66,"------------"
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 " ("_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
;
MAIL3(MSG) ;
S PSOINST=$P($G(^DIC(4,+$P($G(^XMB(1,1,"XUS")),"^",17),99)),"^")
D NOW^%DTC S Y=% D DD^%DT S PSOEND=Y
K PSOTEXT
S XMY(DUZ)=""
S XMY("NAPOLIELLO.GREG@FORUM.VA.GOV")=""
S XMY("WHITE.ELAINE@FORUM.VA.GOV")=""
S:$$PROD^XUPROD(1) XMY("WILLIAMSON.ERIC@FORUM.VA.GOV")=""
S XMDUZ="PSO*7*215 TALLY"
S XMSUB="STATION "_$G(PSOINST)
S XMSUB=XMSUB_$S($$PROD^XUPROD(1):"(Prod)",1:"(Test)")
S XMSUB=XMSUB_" UNBILLED COPAYS FOR PRESCRIPTION REFILLS"
S PSOTEXT(1)=""
S PSOTEXT(2)="Started "_PSOSTART
S PSOTEXT(3)=""
S PSOTEXT(4)=" "_MSG
S XMTEXT="PSOTEXT(" N DIFROM D ^XMD K XMDUZ,XMTEXT,XMSUB
Q
PSOCPBK2 ;BIR/EJW,GN-Tally Automated-release refill copay cont. ;8/10/05 12:03pm
+1 ;;7.0;OUTPATIENT PHARMACY;**215,303**;DEC 1997;Build 19
+2 ;External reference to ^PSDRUG supported by DBIA 221
+3 ;External reference to ^IBAM(354.7 supported by DBIA 3877
+4 ;External reference to $$PROD^XUPROD(1) supported by DBIA 4440
+5 ;
TALLY ;
+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
+4 SET PSODFN=0
+5 FOR QQ=1:1
SET PSODFN=$ORDER(^XTMP(NAMSP,PSODFN))
IF 'PSODFN
QUIT
Begin DoDot:1
+6 IF QQ#100=0
IF $DATA(^XTMP(NAMSP,0,"STOP"))
KILL ^XTMP(NAMSP)
SET STOP=1
+7 ; INITIAL ANNUAL CAP FOR 2004 & 2005
SET (PSOCAP(304),PSOCAP(305))=0
+8 FOR RXP=0:0
SET RXP=$ORDER(^XTMP(NAMSP,PSODFN,RXP))
IF 'RXP
QUIT
Begin DoDot:2
+9 FOR YY=0:0
SET YY=$ORDER(^XTMP(NAMSP,PSODFN,RXP,YY))
IF YY=""
QUIT
Begin DoDot:3
+10 SET PSOREL=$GET(^XTMP(NAMSP,PSODFN,RXP,YY))
+11 ; MET ANNUAL CAP FOR 2004 OR 2005
IF PSOCAP($EXTRACT(PSOREL,1,3))
QUIT
+12 ; REFILL LEVEL
IF $PIECE($GET(^PSRX(RXP,1,YY,"IB")),"^",1)=""
Begin DoDot:4
+13 DO SITE
+14 DO CP
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
IF STOP
QUIT
+15 QUIT
+16 ;
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
GOTO QUIT
+10 ;already attempted to bill, but exceeded Anuual Cap
+11 IF 'PSOREF
IF +$PIECE($GET(^PSRX(RXP,"IB")),"^",4)>0
GOTO 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
GOTO 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
GOTO QUIT
+23 IF PSOCHG=2
IF 'PSOCP
GOTO QUIT
+24 ; Units for COPAY
+25 ;calc number of 30-day units eligible to bill
+26 SET PSOCPUN=($PIECE(^PSRX(RXP,0),"^",8)+29)\30
+27 DO ACCUM
QUIT ;
+1 KILL Y,PSOCP1,PSOCP2,PSOCPN,X,PSOCPUN,PSOREF,PSOCHG,PSOSAVE,PREA,PSORSN
+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
+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
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 QUIT
+12 ;
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 yegt 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 ;see if current refill added to tot exceeds annual cap and quit
+15 IF PSOTOT+(7*PSOCPUN)>840
SET PSOCAP(PSOYR)=1
QUIT
+16 ;
+17 ;update Xtmp tot nodes with current refill amounts
+18 SET ^XTMP(NAMSP,PSODFN,PSOYEAR)=PSOTOT+(PSOCPUN*7)
+19 SET ^XTMP(NAMSP,PSODFN,PSOYEAR,PSOCPUN)=$GET(^XTMP(NAMSP,PSODFN,PSOYEAR,PSOCPUN))+1
+20 ;
+21 ;indicate this refill would be billable by adding to Xtmp "BILLED"
+22 NEW PSONAM
+23 SET PSONAM=$PIECE($GET(^DPT(PSODFN,0)),"^")
SET PSONAM=$PIECE(PSONAM,",")
+24 SET PSONAM=$EXTRACT(PSONAM,1,6)
+25 SET ^XTMP(NAMSP,"BILLED",PSONAM,PSODFN,RXP,PSOREF)=PSOREL
+26 QUIT
+27 ;
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 NAMSP
SET NAMSP=$$NAMSP^PSOCPBK1
+2 LOCK +^XTMP(NAMSP):0
IF '$TEST
Begin DoDot:1
+3 WRITE !,"Copay Tally job for PSO*7*215 is still running. Halting..."
End DoDot:1
QUIT
+4 LOCK -^XTMP(NAMSP)
+5 WRITE !!,"This report shows the patient name and prescription information for refills"
+6 WRITE !,"that were indentified as billable by the tally patch PSO*7*215"
+7 WRITE !!,"You may queue the report to print, if you wish.",!
+8 ;
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^PSOCPBK2"
SET ZTDESC="Potential Billable copay report"
DO ^%ZTLOAD
KILL %ZSI
WRITE !,"Report queued to print.",!
GOTO DONE
START ;
+1 USE IO
+2 NEW NAMSP
SET NAMSP=$$NAMSP^PSOCPBK1
+3 SET PSOOUT=0
SET PSODV=$SELECT($EXTRACT(IOST)="C":"C",1:"P")
+4 SET PSOPGCT=0
SET PSOPGLN=IOSL-7
SET PSOPGCT=1
+5 DO TITLE
+6 SET PSONAM=""
+7 FOR
SET PSONAM=$ORDER(^XTMP(NAMSP,"BILLED",PSONAM))
IF PSONAM=""
QUIT
Begin DoDot:1
+8 SET PSODFN=""
+9 FOR
SET PSODFN=$ORDER(^XTMP(NAMSP,"BILLED",PSONAM,PSODFN))
IF PSODFN=""
QUIT
Begin DoDot:2
+10 SET RXP=""
+11 FOR
SET RXP=$ORDER(^XTMP(NAMSP,"BILLED",PSONAM,PSODFN,RXP))
IF RXP=""
QUIT
Begin DoDot:3
+12 SET PSOFILL=""
+13 FOR
SET PSOFILL=$ORDER(^XTMP(NAMSP,"BILLED",PSONAM,PSODFN,RXP,PSOFILL))
IF PSOFILL=""
QUIT
Begin DoDot:4
+14 NEW XX,PSONAME
+15 SET XX=$GET(^XTMP(NAMSP,"BILLED",PSONAM,PSODFN,RXP,PSOFILL))
Begin DoDot:5
+16 DO FULL
IF $GET(PSOOUT)
QUIT
SET PSONAME=$PIECE($GET(^DPT(PSODFN,0)),"^")
+17 WRITE !,$EXTRACT(PSONAME,1,14)
DO PRTSSN
+18 WRITE ?46," ",RXP," (",PSOFILL,")"
Begin DoDot:6
+19 SET Y=XX
IF Y>0
XECUTE ^DD("DD")
+20 WRITE ?65," ",Y
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+21 GOTO END
+22 ;
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*215 -COPAY PRESCRIPTION REFILLS BILLABLE"
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 !,"PATIENT NAME (SSN) DIV",?48,"RX# (FILL)",?66,"RELEASE DATE"
+8 WRITE !,"-------------- ------- ----------------",?47,"------------"
+9 WRITE ?66,"------------"
+10 SET PSOPGCT=PSOPGCT+1
+11 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 " ("_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
+12 ;
MAIL3(MSG) ;
+1 SET PSOINST=$PIECE($GET(^DIC(4,+$PIECE($GET(^XMB(1,1,"XUS")),"^",17),99)),"^")
+2 DO NOW^%DTC
SET Y=%
DO DD^%DT
SET PSOEND=Y
+3 KILL PSOTEXT
+4 SET XMY(DUZ)=""
+5 SET XMY("NAPOLIELLO.GREG@FORUM.VA.GOV")=""
+6 SET XMY("WHITE.ELAINE@FORUM.VA.GOV")=""
+7 IF $$PROD^XUPROD(1)
SET XMY("WILLIAMSON.ERIC@FORUM.VA.GOV")=""
+8 SET XMDUZ="PSO*7*215 TALLY"
+9 SET XMSUB="STATION "_$GET(PSOINST)
+10 SET XMSUB=XMSUB_$SELECT($$PROD^XUPROD(1):"(Prod)",1:"(Test)")
+11 SET XMSUB=XMSUB_" UNBILLED COPAYS FOR PRESCRIPTION REFILLS"
+12 SET PSOTEXT(1)=""
+13 SET PSOTEXT(2)="Started "_PSOSTART
+14 SET PSOTEXT(3)=""
+15 SET PSOTEXT(4)=" "_MSG
+16 SET XMTEXT="PSOTEXT("
NEW DIFROM
DO ^XMD
KILL XMDUZ,XMTEXT,XMSUB
+17 QUIT
