PSOSULB1.m

PSOSULB1 ;BHAM ISC/RTR,SAB-Print suspended labels  cont. ;29-May-2012 15:15;PLS

 ;;7.0;OUTPATIENT PHARMACY;**10,1008,200,264,289,1015**;DEC 1997;Build 62

 ;Reference to $$INSUR^IBBAPI supported by IA 4419

 ;Reference to $$DEA^IBNCPDP controlled subscription by IA 4299

 ; Modified - IHS/MSC/PLS - 05/22/09 - Line QUE+4

DEV D:'$D(PSOPAR) ^PSOLSET G:'$D(PSOPAR) DEV S PSOION=ION

 N X S X="PSXRSUS" X ^%ZOSF("TEST") G:($T)&($G(PSXSYS))&($D(^XUSEC("PSXCMOPMGR",DUZ)))&($D(^XUSEC("PSX XMIT",DUZ))) ^PSXRSUS

DEV1 I '$P(PSOPAR,"^",8) G START

 N PSOPROP,PFIO W $C(7),!!,"PROFILES MUST BE SENT TO PRINTER !!",! K IOP,%ZIS,IO("Q"),POP S %ZIS="MNQ",%ZIS("A")="Select PROFILE Device: " D ^%ZIS K %ZIS("A") G:POP EXIT^PSOSULBL G:$E(IOST)["C"!(PSOION=ION) DEV S PSOPROP=ION D ^%ZISC

START I $G(PSOCUTDT)']"" S X1=DT,X2=-120 D C^%DTC S PSODTCUT=X,PSOPRPAS=$P(PSOPAR,"^",7)

ASK K ^TMP($J),PSOSU,PSOSUSPR S PFIOQ=0,PDUZ=DUZ W !

 S %DT="AEX",%DT("A")="Print labels through date: ",%DT("B")="TODAY" D ^%DT K %DT D:Y<0 MESS G:Y<0 EXIT^PSOSULBL S PRTDT=Y

 I '$O(^PS(52.5,"C",0))!($O(^(0))>PRTDT) W $C(7),!!,"NOTHING THRU DATE TO PRINT" G ASK

 W ! K DIR S DIR("A")="Sort by Patient Name, ID#, or DEA Special Handling",DIR(0)="SB^P:PATIENT NAME;I:IDENTIFICATION NUMBER;D:DEA SPECIAL HANDLING"

 S DIR("?")="Enter 'P' to sort the labels alphabetically by name, enter 'I' to sort by identification number, enter 'D' to sort by DEA Special Handling."

 S DIR("?",1)="Sorting by DEA Special Handling will print the labels in three groups. The",DIR("?",2)="first will contain labels with drugs marked with an A or C in the DEA Special"

 S DIR("?",3)="Handling field, indicating NARCOTICS AND ALCOHOLICS, and CONTROLLED SUBSTANCES-",DIR("?",4)="NON NARCOTIC. The second group will contain ones marked with an S, indicating"

 S DIR("?",5)="SUPPLY, and all others will print in the third group.",DIR("?",6)=""

 D ^DIR K DIR D:$D(DIRUT) MESS G:$D(DIRUT) EXIT^PSOSULBL S PSRT=$S(Y="D":"D",Y="P":1,1:0)

 I Y="D" W ! K DIR S DIR(0)="SB^P:PATIENT NAME;I:IDENTIFICATION NUMBER",DIR("A")="Within DEA Special Handling, sort by Patient Name or ID#" D ^DIR K DIR D:$D(DIRUT) MESS G:$D(DIRUT) EXIT^PSOSULBL S PSRTONE=Y

 S X1=PRTDT,X2=$P(PSOPAR,"^",27) D C^%DTC S XDATE=X K IOP,POP,IO("Q"),ZTSK

PRLBL W ! S %ZIS("A")="Printer 'LABEL' Device: ",%ZIS("B")="",%ZIS="MQN" D ^%ZIS S PSLION=ION I POP S IOP=PSOION D ^%ZIS D MESS G EXIT^PSOSULBL

 I $E(IOST)'["P" D MESSL G PRLBL

 N PSOIOS S PSOIOS=IOS D DEVBAR^PSOBMST

 S PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$P(PSOPAR,"^",19)

 K PSOION D ^%ZISC I $D(IO("Q")) K IO("Q")

QUE K %DT,PSOTIME,PSOOUT D NOW^%DTC S %DT="REAX",%DT(0)=%,%DT("B")="NOW",%DT("A")="Queue to run at what time: " D ^%DT K %DT I $D(DTOUT)!(Y<0) D MESS G EXIT^PSOSULBL

 S (PSOSUSPR,PSODBQ)=1,PSOTIME=Y

 S ZTRTN="BEG^PSOSULBL",ZTDESC="PRINT LABELS FROM SUSPENSE",ZTIO=PSLION,ZTDTH=PSOTIME

 F G="PSOPAR","PSOSYS","PSOSUSPR","PSODBQ","PSRT","PSRTONE","PSOPROP","PSLION","PFIO","PSOBARS","PSODTCUT","PSOPRPAS","PRTDT","PDUZ","PSOBAR0","PSOBAR1","PSOSITE","XDATE","PSOTIME" S:$D(@G) ZTSAVE(G)=""

 S ZTSAVE("APS*")=""

 D ^%ZTLOAD W !!,"PRINT FROM SUSPENSE JOB QUEUED!",! D ^%ZISC G EXIT^PSOSULBL

 ;G:PSRT'="D" BEG^PSOSULBL

MESS W $C(7),!!?3,"NOTHING QUEUED TO PRINT!",! Q

MESSL W $C(7),!?3,"LABELS MUST BE SENT TO A PRINTER!",! Q

BAIMAIL ;Send mail message

 S:'$G(PDUZ) PDUZ=+$G(DUZ)

 K ^TMP("PSOM",$J)

 N SEQ,XMY,XMDUZ,XMSUB,XMTEXT,SEQ,NAME,PSSN,RX,FILL,FIRST

 S SEQ=1

 S XMY(PDUZ)=""

 S XMY("G.PSO EXTERNAL DISPENSE ALERTS")=""

 S XMDUZ="OUTPATIENT PHARMACY PACKAGE"

 S XMSUB="BAD ADDRESS SUSPENSE NOT PRINTED"

 I $G(PSOSITE) S XMSUB=$$GET1^DIQ(59,PSOSITE,.06)_" "_XMSUB

 S ^TMP("PSOM",$J,SEQ)="The following prescriptions with a routing of mail were not printed/sent to",SEQ=SEQ+1

 S ^TMP("PSOM",$J,SEQ)="external interface due to the BAD ADDRESS INDICATOR being set and no active",SEQ=SEQ+1

 S ^TMP("PSOM",$J,SEQ)="temporary address, or the patient has an active MAIL status of DO NOT MAIL, or",SEQ=SEQ+1

 S ^TMP("PSOM",$J,SEQ)="the patient has a foreign address:",SEQ=SEQ+1

 S NAME="" F  S NAME=$O(^TMP("PSOSM",$J,NAME)) Q:NAME=""  D

 .S PSSN="" F  S PSSN=$O(^TMP("PSOSM",$J,NAME,PSSN)) Q:PSSN=""  D

 ..S ^TMP("PSOM",$J,SEQ)="",SEQ=SEQ+1

 ..S ^TMP("PSOM",$J,SEQ)=NAME_"   "_PSSN,FIRST=1

 ..S RX=0 F  S RX=$O(^TMP("PSOSM",$J,NAME,PSSN,RX)) Q:'RX  S FILL="" F  S FILL=$O(^TMP("PSOSM",$J,NAME,PSSN,RX,FILL)) Q:FILL=""  D

 ...I FIRST D  S FIRST=0

 ....S ^TMP("PSOM",$J,SEQ)=^TMP("PSOM",$J,SEQ)_"   ("_$G(^TMP("PSOSM",$J,NAME,PSSN,RX,FILL))_")"

 ....S SEQ=SEQ+1

 ...S ^TMP("PSOM",$J,SEQ)="  "_$P(^PSRX(RX,0),"^")_" ("_FILL_")  "_$P($G(^PSDRUG($P(^PSRX(RX,0),"^",6),0)),"^"),SEQ=SEQ+1

 S ^TMP("PSOM",$J,SEQ+1)=""

 S XMTEXT="^TMP(""PSOM"",$J," N DIFROM D ^XMD K XMSUB,XMTEXT,XMY,XMDUZ

 Q

 ;Description:

 ;This function determines whether the RX SUSPENSE has a DAYS SUPPLY HOLD

 ;condition.

 ;Input: REC = Pointer to Suspense file (#52.5)

 ;Returns: 1 or 0

 ;1 (one) if ¾ of days supply has elapsed.

 ;0 (zero) is returned if ¾ of days supply has not elapsed.

 ;

DSH(REC) ; ePharmacy - verify that 3/4 days supply has elapsed before printing from suspense

 N PSINSUR,PSARR,SHDT,DSHOLD,DSHDT,PS0,COMM,DIE,DA,DR,RXIEN,RFL,DAYSSUP,LSTFIL,PTDFN,IBINS,DRG

 N DEA,DEAOK,ICD,SFN,SDT

 S DSHOLD=1,PS0=^PS(52.5,REC,0),RXIEN=$P(PS0,U,1),RFL=$P(PS0,U,13)

 S LSTFIL=$$LSTRFL^PSOBPSU1(RXIEN),PTDFN=$$GET1^DIQ(52,RXIEN,"2","I")

 S IBSTAT=$$INSUR^IBBAPI(PTDFN,,"E",.IBINS,"1"),DRG=$$GET1^DIQ(52,RXIEN,"6","I")

 S (DEA,ICD)="",DEA=$$GET1^DIQ(50,DRG,3)

 I $D(^PSRX(RXIEN,"ICD",1,0)) S ICD=^PSRX(RXIEN,"ICD",1,0)

 ;

 ; Don't hold Rx where the previous fill was not ebillable

 I $$STATUS^BPSOSRX(RXIEN,LSTFIL-1)="" Q DSHOLD

 ; Don't hold when the Rx has SC/EI flagged

 I ICD[1 Q DSHOLD

 ; Don't hold rx if DEA special Handling code is non billable (i.e. has M or 0 (zero) or (I, S, N, and/or 9)) without an E

 S DEAOK=$$DEA^IBNCPDP(DEA) I 'DEAOK Q DSHOLD

 ; Don't hold for zero fill renewals

 I 'LSTFIL,$$GET1^DIQ(52,RXIEN_",","PRIOR FILL DATE",,,)="" Q DSHOLD

 ; Don't hold if no insurance

 I 'IBSTAT!(IBSTAT=-1) Q DSHOLD

 ;

 S DSHDT=$$DSHDT(RXIEN) ; 3/4 of days supply date

 I DSHDT>DT S DSHOLD=0 D

 . I DSHDT'=$P(PS0,U,14) D  ; Update Suspense Hold Date and Activity Log

 . . S COMM="3/4 of Days Supply SUSPENSE HOLD until "_$$FMTE^XLFDT(DSHDT,"2D")_"."

 . . S DAYSSUP=$$LFDS(RXIEN)

 . . D RXACT^PSOBPSU2(RXIEN,RFL,COMM,"S",+$G(DUZ)) ; Update Activity Log

 . . S DR="10///^S X=DSHDT",DIE="^PS(52.5,",DA=REC D ^DIE ; File Suspense Hold Date

 . . N DA,DIE,DR,PSOX,SFN,INDT,DEAD,SUB,XOK,OLD,X,II

 . . S DA=REC,DIE="^PS(52.5,",DR=".02///"_DSHDT D ^DIE

 . . S SFN=REC,DEAD=0,INDT=DSHDT D CHANGE^PSOSUCH1(RXIEN,RFL)

 Q DSHOLD

 ;

 ;Description:

 ;This function determines the date that 3/4 of the days supply for the

 ;last refill will occur.

 ;Input: RXIEN = Prescription file #52 IEN

 ;Returns: DATE/TIME value

DSHDT(RXIEN) ;

 N RXFIL,FILLDT,DAYSSUP,DSH34

 I '$D(^PSRX(RXIEN,0)) Q -1

 ;S RXFIL=$$LSTRFL^PSOBPSU1(RXIEN) ; Last Refill

 S FILLDT=$$LDPFDT(RXIEN) ; Last Dispensed Date or Prior Fill Date for renewal

 S DAYSSUP=$$LFDS(RXIEN) ; Days Supply of Last Refill

 S DSH34=DAYSSUP*.75 ; 3/4 of Days Supply

 Q $$FMADD^XLFDT(FILLDT,DSH34) ; Return today plus 3/4 of Days Supply date

 ;

 ; Description: This function returns the DAYS SUPPLY for the Latest Fill

 ; for a Prescription

 ; Input: RXIEN = Prescription file #52 IEN

 ; Returns: DAYS SUPPLY for the latest fill

 ;          -1 if RXIEN is not valid

LFDS(RXIEN) ;

 N RXFIL

 Q:'$D(^PSRX(RXIEN)) -1

 S RXFIL=$$LSTRFL^PSOBPSU1(RXIEN)

 Q $S(RXFIL=0:$P(^PSRX(RXIEN,0),U,8),1:$P(^PSRX(RXIEN,1,RXFIL,0),U,10))

 ;

LDPFDT(RXIEN) ; Returns PRIOR FILL DATE if renewal otherwise LAST DISPENSED DATE or -1 if not valid

 Q $S('$D(^PSRX(RXIEN)):-1,$$PRFDT(RXIEN):$$PRFDT(RXIEN),1:$$LDT(RXIEN))

 ;

PRFDT(RXIEN) ; Returns PRIOR FILL DATE in internal format

 Q $$GET1^DIQ(52,RXIEN_",","PRIOR FILL DATE","I",,)

 ;

LDT(RXIEN) ; Returns LAST DISPENSED DATE in internal format

 Q $$GET1^DIQ(52,RXIEN_",","LAST DISPENSED DATE","I",,)

PSOSULB1  ;BHAM ISC/RTR,SAB-Print suspended labels  cont. ;29-May-2012 15:15;PLS

 +1       ;;7.0;OUTPATIENT PHARMACY;**10,1008,200,264,289,1015**;DEC 1997;Build 62

 +2       ;Reference to $$INSUR^IBBAPI supported by IA 4419

 +3       ;Reference to $$DEA^IBNCPDP controlled subscription by IA 4299

 +4       ; Modified - IHS/MSC/PLS - 05/22/09 - Line QUE+4

DEV        IF '$DATA(PSOPAR)

               DO ^PSOLSET

           IF '$DATA(PSOPAR)

               GOTO DEV

           SET PSOION=ION

 +1        NEW X

           SET X="PSXRSUS"

           XECUTE ^%ZOSF("TEST")

           IF ($TEST)&($GET(PSXSYS))&($DATA(^XUSEC("PSXCMOPMGR",DUZ)))&($DATA(^XUSEC("PSX XMIT",DUZ)))

               GOTO ^PSXRSUS

DEV1       IF '$PIECE(PSOPAR,"^",8)

               GOTO START

 +1        NEW PSOPROP,PFIO

           WRITE $CHAR(7),!!,"PROFILES MUST BE SENT TO PRINTER !!",!

           KILL IOP,%ZIS,IO("Q"),POP

           SET %ZIS="MNQ"

           SET %ZIS("A")="Select PROFILE Device: "

           DO ^%ZIS

           KILL %ZIS("A")

           IF POP

               GOTO EXIT^PSOSULBL

           IF $EXTRACT(IOST)["C"!(PSOION=ION)

               GOTO DEV

           SET PSOPROP=ION

           DO ^%ZISC

START      IF $GET(PSOCUTDT)']""

               SET X1=DT

               SET X2=-120

               DO C^%DTC

               SET PSODTCUT=X

               SET PSOPRPAS=$PIECE(PSOPAR,"^",7)

ASK        KILL ^TMP($JOB),PSOSU,PSOSUSPR

           SET PFIOQ=0

           SET PDUZ=DUZ

           WRITE !

 +1        SET %DT="AEX"

           SET %DT("A")="Print labels through date: "

           SET %DT("B")="TODAY"

           DO ^%DT

           KILL %DT

           IF Y<0

               DO MESS

           IF Y<0

               GOTO EXIT^PSOSULBL

           SET PRTDT=Y

 +2        IF '$ORDER(^PS(52.5,"C",0))!($ORDER(^(0))>PRTDT)

               WRITE $CHAR(7),!!,"NOTHING THRU DATE TO PRINT"

               GOTO ASK

 +3        WRITE !

           KILL DIR

           SET DIR("A")="Sort by Patient Name, ID#, or DEA Special Handling"

           SET DIR(0)="SB^P:PATIENT NAME;I:IDENTIFICATION NUMBER;D:DEA SPECIAL HANDLING"

 +4        SET DIR("?")="Enter 'P' to sort the labels alphabetically by name, enter 'I' to sort by identification number, enter 'D' to sort by DEA Special Handling."

 +5        SET DIR("?",1)="Sorting by DEA Special Handling will print the labels in three groups. The"

           SET DIR("?",2)="first will contain labels with drugs marked with an A or C in the DEA Special"

 +6        SET DIR("?",3)="Handling field, indicating NARCOTICS AND ALCOHOLICS, and CONTROLLED SUBSTANCES-"

           SET DIR("?",4)="NON NARCOTIC. The second group will contain ones marked with an S, indicating"

 +7        SET DIR("?",5)="SUPPLY, and all others will print in the third group."

           SET DIR("?",6)=""

 +8        DO ^DIR

           KILL DIR

           IF $DATA(DIRUT)

               DO MESS

           IF $DATA(DIRUT)

               GOTO EXIT^PSOSULBL

           SET PSRT=$SELECT(Y="D":"D",Y="P":1,1:0)

 +9        IF Y="D"

               WRITE !

               KILL DIR

               SET DIR(0)="SB^P:PATIENT NAME;I:IDENTIFICATION NUMBER"

               SET DIR("A")="Within DEA Special Handling, sort by Patient Name or ID#"

               DO ^DIR

               KILL DIR

               IF $DATA(DIRUT)

                   DO MESS

               IF $DATA(DIRUT)

                   GOTO EXIT^PSOSULBL

               SET PSRTONE=Y

 +10       SET X1=PRTDT

           SET X2=$PIECE(PSOPAR,"^",27)

           DO C^%DTC

           SET XDATE=X

           KILL IOP,POP,IO("Q"),ZTSK

PRLBL      WRITE !

           SET %ZIS("A")="Printer 'LABEL' Device: "

           SET %ZIS("B")=""

           SET %ZIS="MQN"

           DO ^%ZIS

           SET PSLION=ION

           IF POP

               SET IOP=PSOION

               DO ^%ZIS

               DO MESS

               GOTO EXIT^PSOSULBL

 +1        IF $EXTRACT(IOST)'["P"

               DO MESSL

               GOTO PRLBL

 +2        NEW PSOIOS

           SET PSOIOS=IOS

           DO DEVBAR^PSOBMST

 +3        SET PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$PIECE(PSOPAR,"^",19)

 +4        KILL PSOION

           DO ^%ZISC

           IF $DATA(IO("Q"))

               KILL IO("Q")

QUE        KILL %DT,PSOTIME,PSOOUT

           DO NOW^%DTC

           SET %DT="REAX"

           SET %DT(0)=%

           SET %DT("B")="NOW"

           SET %DT("A")="Queue to run at what time: "

           DO ^%DT

           KILL %DT

           IF $DATA(DTOUT)!(Y<0)

               DO MESS

               GOTO EXIT^PSOSULBL

 +1        SET (PSOSUSPR,PSODBQ)=1

           SET PSOTIME=Y

 +2        SET ZTRTN="BEG^PSOSULBL"

           SET ZTDESC="PRINT LABELS FROM SUSPENSE"

           SET ZTIO=PSLION

           SET ZTDTH=PSOTIME

 +3        FOR G="PSOPAR","PSOSYS","PSOSUSPR","PSODBQ","PSRT","PSRTONE","PSOPROP","PSLION","PFIO","PSOBARS","PSODTCUT","PSOPRPAS","PRTDT","PDUZ","PSOBAR0","PSOBAR1","PSOSITE","XDATE","PSOTIME"

               IF $DATA(@G)

                   SET ZTSAVE(G)=""

 +4        SET ZTSAVE("APS*")=""

 +5        DO ^%ZTLOAD

           WRITE !!,"PRINT FROM SUSPENSE JOB QUEUED!",!

           DO ^%ZISC

           GOTO EXIT^PSOSULBL

 +6       ;G:PSRT'="D" BEG^PSOSULBL

MESS       WRITE $CHAR(7),!!?3,"NOTHING QUEUED TO PRINT!",!

           QUIT 

MESSL      WRITE $CHAR(7),!?3,"LABELS MUST BE SENT TO A PRINTER!",!

           QUIT 

BAIMAIL   ;Send mail message

 +1        IF '$GET(PDUZ)

               SET PDUZ=+$GET(DUZ)

 +2        KILL ^TMP("PSOM",$JOB)

 +3        NEW SEQ,XMY,XMDUZ,XMSUB,XMTEXT,SEQ,NAME,PSSN,RX,FILL,FIRST

 +4        SET SEQ=1

 +5        SET XMY(PDUZ)=""

 +6        SET XMY("G.PSO EXTERNAL DISPENSE ALERTS")=""

 +7        SET XMDUZ="OUTPATIENT PHARMACY PACKAGE"

 +8        SET XMSUB="BAD ADDRESS SUSPENSE NOT PRINTED"

 +9        IF $GET(PSOSITE)

               SET XMSUB=$$GET1^DIQ(59,PSOSITE,.06)_" "_XMSUB

 +10       SET ^TMP("PSOM",$JOB,SEQ)="The following prescriptions with a routing of mail were not printed/sent to"

           SET SEQ=SEQ+1

 +11       SET ^TMP("PSOM",$JOB,SEQ)="external interface due to the BAD ADDRESS INDICATOR being set and no active"

           SET SEQ=SEQ+1

 +12       SET ^TMP("PSOM",$JOB,SEQ)="temporary address, or the patient has an active MAIL status of DO NOT MAIL, or"

           SET SEQ=SEQ+1

 +13       SET ^TMP("PSOM",$JOB,SEQ)="the patient has a foreign address:"

           SET SEQ=SEQ+1

 +14       SET NAME=""

           FOR 

               SET NAME=$ORDER(^TMP("PSOSM",$JOB,NAME))

               IF NAME=""

                   QUIT 

               Begin DoDot:1

 +15               SET PSSN=""

                   FOR 

                       SET PSSN=$ORDER(^TMP("PSOSM",$JOB,NAME,PSSN))

                       IF PSSN=""

                           QUIT 

                       Begin DoDot:2

 +16                       SET ^TMP("PSOM",$JOB,SEQ)=""

                           SET SEQ=SEQ+1

 +17                       SET ^TMP("PSOM",$JOB,SEQ)=NAME_"   "_PSSN

                           SET FIRST=1

 +18                       SET RX=0

                           FOR 

                               SET RX=$ORDER(^TMP("PSOSM",$JOB,NAME,PSSN,RX))

                               IF 'RX

                                   QUIT 

                               SET FILL=""

                               FOR 

                                   SET FILL=$ORDER(^TMP("PSOSM",$JOB,NAME,PSSN,RX,FILL))

                                   IF FILL=""

                                       QUIT 

                                   Begin DoDot:3

 +19                                   IF FIRST

                                           Begin DoDot:4

 +20                                           SET ^TMP("PSOM",$JOB,SEQ)=^TMP("PSOM",$JOB,SEQ)_"   ("_$GET(^TMP("PSOSM",$JOB,NAME,PSSN,RX,FILL))_")"

 +21                                           SET SEQ=SEQ+1

                                           End DoDot:4

                                           SET FIRST=0

 +22                                   SET ^TMP("PSOM",$JOB,SEQ)="  "_$PIECE(^PSRX(RX,0),"^")_" ("_FILL_")  "_$PIECE($GET(^PSDRUG($PIECE(^PSRX(RX,0),"^",6),0)),"^")

                                       SET SEQ=SEQ+1

                                   End DoDot:3

                       End DoDot:2

               End DoDot:1

 +23       SET ^TMP("PSOM",$JOB,SEQ+1)=""

 +24       SET XMTEXT="^TMP(""PSOM"",$J,"

           NEW DIFROM

           DO ^XMD

           KILL XMSUB,XMTEXT,XMY,XMDUZ

 +25       QUIT 

 +26      ;Description:

 +27      ;This function determines whether the RX SUSPENSE has a DAYS SUPPLY HOLD

 +28      ;condition.

 +29      ;Input: REC = Pointer to Suspense file (#52.5)

 +30      ;Returns: 1 or 0

 +31      ;1 (one) if ¾ of days supply has elapsed.

 +32      ;0 (zero) is returned if ¾ of days supply has not elapsed.

 +33      ;

DSH(REC)  ; ePharmacy - verify that 3/4 days supply has elapsed before printing from suspense

 +1        NEW PSINSUR,PSARR,SHDT,DSHOLD,DSHDT,PS0,COMM,DIE,DA,DR,RXIEN,RFL,DAYSSUP,LSTFIL,PTDFN,IBINS,DRG

 +2        NEW DEA,DEAOK,ICD,SFN,SDT

 +3        SET DSHOLD=1

           SET PS0=^PS(52.5,REC,0)

           SET RXIEN=$PIECE(PS0,U,1)

           SET RFL=$PIECE(PS0,U,13)

 +4        SET LSTFIL=$$LSTRFL^PSOBPSU1(RXIEN)

           SET PTDFN=$$GET1^DIQ(52,RXIEN,"2","I")

 +5        SET IBSTAT=$$INSUR^IBBAPI(PTDFN,,"E",.IBINS,"1")

           SET DRG=$$GET1^DIQ(52,RXIEN,"6","I")

 +6        SET (DEA,ICD)=""

           SET DEA=$$GET1^DIQ(50,DRG,3)

 +7        IF $DATA(^PSRX(RXIEN,"ICD",1,0))

               SET ICD=^PSRX(RXIEN,"ICD",1,0)

 +8       ;

 +9       ; Don't hold Rx where the previous fill was not ebillable

 +10       IF $$STATUS^BPSOSRX(RXIEN,LSTFIL-1)=""

               QUIT DSHOLD

 +11      ; Don't hold when the Rx has SC/EI flagged

 +12       IF ICD[1

               QUIT DSHOLD

 +13      ; Don't hold rx if DEA special Handling code is non billable (i.e. has M or 0 (zero) or (I, S, N, and/or 9)) without an E

 +14       SET DEAOK=$$DEA^IBNCPDP(DEA)

           IF 'DEAOK

               QUIT DSHOLD

 +15      ; Don't hold for zero fill renewals

 +16       IF 'LSTFIL

               IF $$GET1^DIQ(52,RXIEN_",","PRIOR FILL DATE",,,)=""

                   QUIT DSHOLD

 +17      ; Don't hold if no insurance

 +18       IF 'IBSTAT!(IBSTAT=-1)

               QUIT DSHOLD

 +19      ;

 +20      ; 3/4 of days supply date

           SET DSHDT=$$DSHDT(RXIEN)

 +21       IF DSHDT>DT

               SET DSHOLD=0

               Begin DoDot:1

 +22      ; Update Suspense Hold Date and Activity Log

                   IF DSHDT'=$PIECE(PS0,U,14)

                       Begin DoDot:2

 +23                       SET COMM="3/4 of Days Supply SUSPENSE HOLD until "_$$FMTE^XLFDT(DSHDT,"2D")_"."

 +24                       SET DAYSSUP=$$LFDS(RXIEN)

 +25      ; Update Activity Log

                           DO RXACT^PSOBPSU2(RXIEN,RFL,COMM,"S",+$GET(DUZ))

 +26      ; File Suspense Hold Date

                           SET DR="10///^S X=DSHDT"

                           SET DIE="^PS(52.5,"

                           SET DA=REC

                           DO ^DIE

 +27                       NEW DA,DIE,DR,PSOX,SFN,INDT,DEAD,SUB,XOK,OLD,X,II

 +28                       SET DA=REC

                           SET DIE="^PS(52.5,"

                           SET DR=".02///"_DSHDT

                           DO ^DIE

 +29                       SET SFN=REC

                           SET DEAD=0

                           SET INDT=DSHDT

                           DO CHANGE^PSOSUCH1(RXIEN,RFL)

                       End DoDot:2

               End DoDot:1

 +30       QUIT DSHOLD

 +31      ;

 +32      ;Description:

 +33      ;This function determines the date that 3/4 of the days supply for the

 +34      ;last refill will occur.

 +35      ;Input: RXIEN = Prescription file #52 IEN

 +36      ;Returns: DATE/TIME value

DSHDT(RXIEN) ;

 +1        NEW RXFIL,FILLDT,DAYSSUP,DSH34

 +2        IF '$DATA(^PSRX(RXIEN,0))

               QUIT -1

 +3       ;S RXFIL=$$LSTRFL^PSOBPSU1(RXIEN) ; Last Refill

 +4       ; Last Dispensed Date or Prior Fill Date for renewal

           SET FILLDT=$$LDPFDT(RXIEN)

 +5       ; Days Supply of Last Refill

           SET DAYSSUP=$$LFDS(RXIEN)

 +6       ; 3/4 of Days Supply

           SET DSH34=DAYSSUP*.75

 +7       ; Return today plus 3/4 of Days Supply date

           QUIT $$FMADD^XLFDT(FILLDT,DSH34)

 +8       ;

 +9       ; Description: This function returns the DAYS SUPPLY for the Latest Fill

 +10      ; for a Prescription

 +11      ; Input: RXIEN = Prescription file #52 IEN

 +12      ; Returns: DAYS SUPPLY for the latest fill

 +13      ;          -1 if RXIEN is not valid

LFDS(RXIEN) ;

 +1        NEW RXFIL

 +2        IF '$DATA(^PSRX(RXIEN))

               QUIT -1

 +3        SET RXFIL=$$LSTRFL^PSOBPSU1(RXIEN)

 +4        QUIT $SELECT(RXFIL=0:$PIECE(^PSRX(RXIEN,0),U,8),1:$PIECE(^PSRX(RXIEN,1,RXFIL,0),U,10))

 +5       ;

LDPFDT(RXIEN) ; Returns PRIOR FILL DATE if renewal otherwise LAST DISPENSED DATE or -1 if not valid

 +1        QUIT $SELECT('$DATA(^PSRX(RXIEN)):-1,$$PRFDT(RXIEN):$$PRFDT(RXIEN),1:$$LDT(RXIEN))

 +2       ;

PRFDT(RXIEN) ; Returns PRIOR FILL DATE in internal format

 +1        QUIT $$GET1^DIQ(52,RXIEN_",","PRIOR FILL DATE","I",,)

 +2       ;

LDT(RXIEN) ; Returns LAST DISPENSED DATE in internal format

 +1        QUIT $$GET1^DIQ(52,RXIEN_",","LAST DISPENSED DATE","I",,)