- PSOSULB1 ;BHAM ISC/RTR,SAB - Print suspended labels cont. ;10/10/96
- ;;7.0;OUTPATIENT PHARMACY;**10,200,264,289,367,421,448,452,561**;DEC 1997;Build 41
- ;Reference to $$INSUR^IBBAPI supported by IA 4419
- ;Reference to $$BILLABLE^IBNCPDP supported by IA 6243
- ;
- 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) G ^PSOSUCAT ;Print Suspense by Category //rtw
- 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)=""
- S DIR("T")=DTIME
- 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
- ;
- FDAPRT ; Selects FDA Medication Guide Printer
- I $$GET1^DIQ(59,PSOSITE,134)'="" N FDAPRT S FDAPRT="" D I FDAPRT="^"!($G(PSOFDAPT)="") G EXIT^PSOSULBL
- . F D Q:FDAPRT'=""
- . . S FDAPRT=$$SELPRT^PSOFDAUT($P($G(PSOFDAPT),"^"))
- . . I FDAPRT="" W $C(7),!,"You must select a valid FDA Medication Guide printer."
- . I FDAPRT'="",(FDAPRT'="^") S PSOFDAPT=FDAPRT
- ;
- 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
- S ZTSAVE("PSOSULST(")="" ;Print Suspense by Category //RTW
- S PSOG="" F PSOG="PSOPAR","PSOSYS","PSOSUSPR","PSODBQ","PSRT","PSRTONE","PSOPROP","PSLION","PFIO","PSOBARS","PSODTCUT","PSOPRPAS","PRTDT","PDUZ","PSOBAR0","PSOBAR1","PSOSITE","XDATE","PSOTIME","PSOFDAPT" S:$D(@PSOG) ZTSAVE(PSOG)=""
- 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
- ;
- ; DSH determines whether a prescription has a 3/4 days supply hold
- ; condition.
- ; Input: REC = Pointer to Suspense file (#52.5)
- ; Returns: 1 or 0
- ; 1 (one) if 3/4 of days supply has elapsed.
- ; 0 (zero) if 3/4 of days supply has not elapsed.
- ;
- DSH(REC) ; ePharmacy - verify that 3/4 days supply has elapsed before printing from suspense
- ;
- N COMM,DA,DAYSSUP,DIE,DR,DSHDT,DSHOLD
- N PREVRX,PSARR,PSINSUR,RFL,RXIEN,SDT,SFN,SHDT
- ;
- S DSHOLD=1
- S RXIEN=$$GET1^DIQ(52.5,REC,.01,"I")
- S RFL=$$GET1^DIQ(52.5,REC,9,"I")
- I RFL="" S RFL=$$LSTRFL^PSOBPSU1(RXIEN)
- ;
- ; If the Rx/Fill is not e-billable, then Quit out.
- ;
- I '$$EBILLABLE^PSOSULB2(RXIEN,RFL) Q DSHOLD
- ;
- S DSHDT=$$DSHDT(RXIEN,RFL) ; 3/4 of days supply date
- S PREVRX=$P(DSHDT,U,2)
- S DSHDT=$P(DSHDT,U)
- I DSHDT>DT S DSHOLD=0 D
- . I DSHDT'=$$GET1^DIQ(52.5,REC,10,"I") D ; Update Suspense Hold Date and Activity Log
- . . ; If a previous Rx is used in the 3/4 days' supply calculation,
- . . ; capture that Rx in the activity log.
- . . S COMM="3/4 of Days Supply SUSPENSE HOLD until "_$$FMTE^XLFDT(DSHDT,"2D")
- . . I PREVRX'="" S COMM=COMM_" (prior Rx "_PREVRX_")"
- . . S COMM=COMM_"."
- . . 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
- . . 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
- . Q
- ;
- Q DSHOLD
- ;
- DSHDT(RXIEN,RFL) ; ePharmacy function to determine the 3/4 of the days supply date
- ; Input: RXIEN = Prescription file #52 ien
- ; RFL = fill#
- ; Returns: DATE value of last date of service plus 3/4 of days supply
- ; PREVRX = Previous Rx if PREVRX^PSOREJP2 identified one that
- ; should be used in the 3/4 days' supply calculation.
- ;
- N FILLDT,DAYSSUP,DSH34,PREVRX
- I '$D(^PSRX(RXIEN,0)) Q -1
- I $G(RFL)="" Q -1
- ;
- D PREVRX^PSOREJP2(RXIEN,RFL,,.FILLDT,.DAYSSUP,.PREVRX)
- I FILLDT="" Q -1
- ;
- S DSH34=DAYSSUP*.75 ; 3/4 of Days Supply
- S:DSH34["." DSH34=(DSH34+1)\1
- ; Return last date of service plus 3/4 of Days Supply date
- ; and the previous Rx used in the calculation, if any.
- Q $$FMADD^XLFDT(FILLDT,DSH34)_U_PREVRX
- ;
- ;
- ; 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))
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOSULB1 7998 printed Jan 18, 2025@03:36:36 Page 2
- PSOSULB1 ;BHAM ISC/RTR,SAB - Print suspended labels cont. ;10/10/96
- +1 ;;7.0;OUTPATIENT PHARMACY;**10,200,264,289,367,421,448,452,561**;DEC 1997;Build 41
- +2 ;Reference to $$INSUR^IBBAPI supported by IA 4419
- +3 ;Reference to $$BILLABLE^IBNCPDP supported by IA 6243
- +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 ;Print Suspense by Category //rtw
- IF $GET(PSOCUTDT)']""
- SET X1=DT
- SET X2=-120
- DO C^%DTC
- SET PSODTCUT=X
- SET PSOPRPAS=$PIECE(PSOPAR,"^",7)
- GOTO ^PSOSUCAT
- 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 SET DIR("T")=DTIME
- +9 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)
- +10 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
- +11 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 ;
- FDAPRT ; Selects FDA Medication Guide Printer
- +1 IF $$GET1^DIQ(59,PSOSITE,134)'=""
- NEW FDAPRT
- SET FDAPRT=""
- Begin DoDot:1
- +2 FOR
- Begin DoDot:2
- +3 SET FDAPRT=$$SELPRT^PSOFDAUT($PIECE($GET(PSOFDAPT),"^"))
- +4 IF FDAPRT=""
- WRITE $CHAR(7),!,"You must select a valid FDA Medication Guide printer."
- End DoDot:2
- if FDAPRT'=""
- QUIT
- +5 IF FDAPRT'=""
- IF (FDAPRT'="^")
- SET PSOFDAPT=FDAPRT
- End DoDot:1
- IF FDAPRT="^"!($GET(PSOFDAPT)="")
- GOTO EXIT^PSOSULBL
- +6 ;
- +7 NEW PSOIOS
- SET PSOIOS=IOS
- DO DEVBAR^PSOBMST
- +8 SET PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$PIECE(PSOPAR,"^",19)
- +9 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 ;Print Suspense by Category //RTW
- SET ZTSAVE("PSOSULST(")=""
- +4 SET PSOG=""
- FOR PSOG="PSOPAR","PSOSYS","PSOSUSPR","PSODBQ","PSRT","PSRTONE","PSOPROP","PSLION","PFIO","PSOBARS","PSODTCUT","PSOPRPAS","PRTDT","PDUZ","PSOBAR0","PSOBAR1","PSOSITE","XDATE","PSOTIME","PSOFDAPT"
- if $DATA(@PSOG)
- SET ZTSAVE(PSOG)=""
- +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 ;
- +27 ; DSH determines whether a prescription has a 3/4 days supply hold
- +28 ; condition.
- +29 ; Input: REC = Pointer to Suspense file (#52.5)
- +30 ; Returns: 1 or 0
- +31 ; 1 (one) if 3/4 of days supply has elapsed.
- +32 ; 0 (zero) if 3/4 of days supply has not elapsed.
- +33 ;
- DSH(REC) ; ePharmacy - verify that 3/4 days supply has elapsed before printing from suspense
- +1 ;
- +2 NEW COMM,DA,DAYSSUP,DIE,DR,DSHDT,DSHOLD
- +3 NEW PREVRX,PSARR,PSINSUR,RFL,RXIEN,SDT,SFN,SHDT
- +4 ;
- +5 SET DSHOLD=1
- +6 SET RXIEN=$$GET1^DIQ(52.5,REC,.01,"I")
- +7 SET RFL=$$GET1^DIQ(52.5,REC,9,"I")
- +8 IF RFL=""
- SET RFL=$$LSTRFL^PSOBPSU1(RXIEN)
- +9 ;
- +10 ; If the Rx/Fill is not e-billable, then Quit out.
- +11 ;
- +12 IF '$$EBILLABLE^PSOSULB2(RXIEN,RFL)
- QUIT DSHOLD
- +13 ;
- +14 ; 3/4 of days supply date
- SET DSHDT=$$DSHDT(RXIEN,RFL)
- +15 SET PREVRX=$PIECE(DSHDT,U,2)
- +16 SET DSHDT=$PIECE(DSHDT,U)
- +17 IF DSHDT>DT
- SET DSHOLD=0
- Begin DoDot:1
- +18 ; Update Suspense Hold Date and Activity Log
- IF DSHDT'=$$GET1^DIQ(52.5,REC,10,"I")
- Begin DoDot:2
- +19 ; If a previous Rx is used in the 3/4 days' supply calculation,
- +20 ; capture that Rx in the activity log.
- +21 SET COMM="3/4 of Days Supply SUSPENSE HOLD until "_$$FMTE^XLFDT(DSHDT,"2D")
- +22 IF PREVRX'=""
- SET COMM=COMM_" (prior Rx "_PREVRX_")"
- +23 SET COMM=COMM_"."
- +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
- +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)
- +30 QUIT
- End DoDot:2
- +31 QUIT
- End DoDot:1
- +32 ;
- +33 QUIT DSHOLD
- +34 ;
- DSHDT(RXIEN,RFL) ; ePharmacy function to determine the 3/4 of the days supply date
- +1 ; Input: RXIEN = Prescription file #52 ien
- +2 ; RFL = fill#
- +3 ; Returns: DATE value of last date of service plus 3/4 of days supply
- +4 ; PREVRX = Previous Rx if PREVRX^PSOREJP2 identified one that
- +5 ; should be used in the 3/4 days' supply calculation.
- +6 ;
- +7 NEW FILLDT,DAYSSUP,DSH34,PREVRX
- +8 IF '$DATA(^PSRX(RXIEN,0))
- QUIT -1
- +9 IF $GET(RFL)=""
- QUIT -1
- +10 ;
- +11 DO PREVRX^PSOREJP2(RXIEN,RFL,,.FILLDT,.DAYSSUP,.PREVRX)
- +12 IF FILLDT=""
- QUIT -1
- +13 ;
- +14 ; 3/4 of Days Supply
- SET DSH34=DAYSSUP*.75
- +15 if DSH34["."
- SET DSH34=(DSH34+1)\1
- +16 ; Return last date of service plus 3/4 of Days Supply date
- +17 ; and the previous Rx used in the calculation, if any.
- +18 QUIT $$FMADD^XLFDT(FILLDT,DSH34)_U_PREVRX
- +19 ;
- +20 ;
- +21 ; Description: This function returns the DAYS SUPPLY for the Latest Fill
- +22 ; for a Prescription
- +23 ; Input: RXIEN = Prescription file #52 IEN
- +24 ; Returns: DAYS SUPPLY for the latest fill
- +25 ; -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 ;