- PSOCPBK2 ;BIR/EJW,GN-Tally Automated-release refill copay cont. ;8/10/05 12:03pm
- ;;7.0;OUTPATIENT PHARMACY;**215,303,460**;DEC 1997;Build 32
- ;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
- ;External reference to $$CPTIER^PSNAPIS(P1,P3) supported by DBIA #2531
- ;External reference to ^XMB(1 supported by DBIA #10091
- ;
- 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,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 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@DOMAIN.EXT")=""
- S XMY("WHITE.ELAINE@DOMAIN.EXT")=""
- S:$$PROD^XUPROD(1) XMY("WILLIAMSON.ERIC@DOMAIN.EXT")=""
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOCPBK2 9060 printed Feb 18, 2025@23:52:13 Page 2
- 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
- +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 ;External reference to $$CPTIER^PSNAPIS(P1,P3) supported by DBIA #2531
- +6 ;External reference to ^XMB(1 supported by DBIA #10091
- +7 ;
- 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,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 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@DOMAIN.EXT")=""
- +6 SET XMY("WHITE.ELAINE@DOMAIN.EXT")=""
- +7 if $$PROD^XUPROD(1)
- SET XMY("WILLIAMSON.ERIC@DOMAIN.EXT")=""
- +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