PSOUTLA1 ;BHAM ISC/RTR-Pharmacy utility program cont. ; 17 Jun 2011 2:21 PM
;;7.0;OUTPATIENT PHARMACY;**35,186,218,259,206,388,444**;DEC 1997;Build 34
;External reference to File ^PS(55 supported by DBIA 2228
;External reference to File ^PSDRUG supported by DBIA 221
;External reference to File ^PS(59.7 supported by DBIA 694
;External reference to File ^PS(51 supported by DBIA 2224
;
;*186 - add DEACHK function
;*218 - add REFIP function
;*259 - reverse *218 delete restriction only warn of deleting
; also add del of last refill only
;
EN1 ;Formats condensed, back door sig in BSIG array
;pass in 1) Internal Rx from 52
; 2) max length of BSIG array
;Returned, still condensed, in BSIG array, when looping through, check for array=null, if so, juist don't print it
EN2(PSOBINTR,PSOBLGTH) ;
K BSIG
N BBSIG,BVAR,BVAR1,III,CNT,NNN,BLIM
S BBSIG=$P($G(^PSRX(PSOBINTR,"SIG")),"^") Q:BBSIG=""!($P($G(^("SIG")),"^",2))
S (BVAR,BVAR1)="",III=1
S CNT=0 F NNN=1:1:$L(BBSIG) I $E(BBSIG,NNN)=" "!($L(BBSIG)=NNN) S CNT=CNT+1 D I $L(BVAR)>PSOBLGTH S BSIG(III)=BLIM_" ",III=III+1,BVAR=BVAR1
.S BVAR1=$P(BBSIG," ",(CNT))
.S BLIM=BVAR
.S BVAR=$S(BVAR="":BVAR1,1:BVAR_" "_BVAR1)
I $G(BVAR)'="" S BSIG(III)=BVAR
I $G(BSIG(1))=""!($G(BSIG(1))=" ") S BSIG(1)=$G(BSIG(2)) K BSIG(2)
Q
;
EN3(PSOBINTR,PSOBLGTH) ;
;Pass in to EN3 the internal Rx number from 52, and the length of
;the array you want. Returns expanded Sig, or warning from PSOHELP
;concantenated with the condensed Sig in the BSIG array
;BACK DOOR ONLY
K BSIG,X N BBSIG,BVAR,BVAR1,III,CNT,NNN,BLIM,Y,SIG,Z0,Z1,BBWARN
S BBSIG=$P($G(^PSRX(PSOBINTR,"SIG")),"^") Q:BBSIG=""!($P($G(^("SIG")),"^",2))
S (SIG,X)=BBSIG
I $E(BBSIG)=" " S BBWARN="Leading spaces are not allowed in the SIG!" G START
S SIG="" Q:$L(X)<1 F Z0=1:1:$L(X," ") G:Z0="" START S Z1=$P(X," ",Z0) D G:'$D(X) START
.I $L(Z1)>32 S BBWARN="MAX OF 32 CHARACTERS ALLOWED BETWEEN SPACES!" K X Q
.D:$D(X)&($G(Z1)]"") S SIG=SIG_" "_Z1
..S Y=$O(^PS(51,"B",Z1,0)) Q:'Y!($P($G(^PS(51,+Y,0)),"^",4)>1) S Z1=$P(^PS(51,Y,0),"^",2) Q:'$D(^(9)) S Y=$P(X," ",Z0-1),Y=$E(Y,$L(Y)) S:Y>1 Z1=^(9)
START ;
S BBSIG=$S($G(BBWARN)="":SIG,1:BBWARN_" "_BBSIG)
S (BVAR,BVAR1)="",III=1
S CNT=0 F NNN=1:1:$L(BBSIG) I $E(BBSIG,NNN)=" "!($L(BBSIG)=NNN) S CNT=CNT+1 D I $L(BVAR)>PSOBLGTH S BSIG(III)=BLIM_" ",III=III+1,BVAR=BVAR1
.S BVAR1=$P(BBSIG," ",(CNT))
.S BLIM=BVAR
.S BVAR=$S(BVAR="":BVAR1,1:BVAR_" "_BVAR1)
I $G(BVAR)'="" S BSIG(III)=BVAR
I $G(BSIG(1))=""!($G(BSIG(1))=" ") S BSIG(1)=$G(BSIG(2)) K BSIG(2)
Q
PATCH ;Allow sites to backfill more than what was done at install
N PSOBACKL,PSOBACKI,PSOBACKS,PSOBACKB,PSOBACKD,PSOBACKA
S PSOBACKL=$O(^PS(59.7,0)),PSOBACKI=$E($P($G(^PS(59.7,+$G(PSOBACKL),49.99)),"^",7),1,7)
I '$G(PSOBACKI) S PSOBACKI=$P($G(^PS(59.7,+$G(PSOBACKL),49.99)),"^",4)
I $G(PSOBACKI) S Y=PSOBACKI D DD^%DT S PSOBACKS=Y S X1=PSOBACKI,X2=-120 D C^%DTC S (Y,PSOBACKB)=X D DD^%DT S PSOBACKD=Y
I $G(PSOBACKD)'="" W !!,"Your CPRS/Outpatient installation date is "_$G(PSOBACKS)_","_" which",!,"means we have already backfilled all active prescriptions and all",!,"prescriptions canceled or expired after "_$G(PSOBACKD)_"."
I W !!,"If you want to backfill orders that were canceled or expired prior to this",!,"date of "_$G(PSOBACKD)_", enter an earlier date and those orders",!,"will be backfilled to CPRS.",!
I $G(PSOBACKD)="" W !!,"We cannot determine the date of the CPRS/Outpatient installation.",!
W !,"If you choose to backfill more orders to CPRS by utilizing this option,",!,"we remind you that disk storage can be significantly affected, depending on",!,"how many orders are backfilled.",!
K DIR S DIR(0)="Y",DIR("B")="N",DIR("A")="Do you want to backfill more prescriptions",DIR("?")="Enter Yes to backfill prescriptions canceled or expired before "_$G(PSOBACKD) D ^DIR K DIR I Y'=1 W ! G PATCHQ
W ! S %DT="AEPX",%DT("A")="Enter Date to begin backfill: " S:$G(PSOBACKB) %DT(0)=-PSOBACKB D ^%DT G:Y<0!($D(DTOUT)) PATCHQ S PSOBACKA=$E(Y,1,7)
W ! K ZTDTH S ZTSAVE("PSOBACKB")="",ZTSAVE("PSOBACKA")="",ZTRTN="PATCHR^PSOUTLA1",ZTDESC="BACKFILL PRSCRIPTIONS TO CPRS",ZTIO="" D ^%ZTLOAD W ! G PATCHQ
PATCHR ;Begin task
N PSOPAL,PSOLPD,PSOLPRX
S PSOBACKA=PSOBACKA-.01
I '$G(PSOBACKB) S PSOBACKB=DT
F PSOPAL=0:0 S PSOPAL=$O(^PS(55,PSOPAL)) Q:'PSOPAL F PSOLPD=PSOBACKA:0 S PSOLPD=$O(^PS(55,PSOPAL,"P","A",PSOLPD)) Q:'PSOLPD!(PSOLPD>PSOBACKB) F PSOLPRX=0:0 S PSOLPRX=$O(^PS(55,PSOPAL,"P","A",PSOLPD,PSOLPRX)) Q:'PSOLPRX D
.I $P($G(^PSRX(PSOLPRX,0)),"^")=""!('$P($G(^(0)),"^",2))!('$P($G(^(0)),"^",6)) Q
.I $P($G(^PSRX(PSOLPRX,"OR1")),"^",2) Q
.I '$P($G(^PSRX(PSOLPRX,0)),"^",19) D
..I $P($G(^PSRX(PSOLPRX,"OR1")),"^")="",+$G(^PSDRUG(+$P($G(^PSRX(PSOLPRX,0)),"^",6),2)) S $P(^PSRX(PSOLPRX,"OR1"),"^")=+$G(^PSDRUG(+$P($G(^PSRX(PSOLPRX,0)),"^",6),2))
..I $P($G(^PSRX(PSOLPRX,0)),"^",10)'="",$G(^PSRX(PSOLPRX,"SIG"))']"",'$O(^PSRX(PSOLPRX,"SIG1",0)) S ^PSRX(PSOLPRX,"SIG")=$P($G(^PSRX(PSOLPRX,0)),"^",10)_"^"_0 S $P(^PSRX(PSOLPRX,0),"^",10)=""
..I $P($G(^PSRX(PSOLPRX,"STA")),"^")="",$P($G(^PSRX(PSOLPRX,0)),"^",15)'="" S $P(^PSRX(PSOLPRX,"STA"),"^")=$P($G(^PSRX(PSOLPRX,0)),"^",15) S $P(^PSRX(PSOLPRX,0),"^",15)=""
..S $P(^PSRX(PSOLPRX,0),"^",19)=1
.S PSOLPSTA=$P($G(^PSRX(PSOLPRX,"STA")),"^") Q:PSOLPSTA=""!(PSOLPSTA=13)!(PSOLPSTA=10)
.D EN^PSOHLSN1(PSOLPRX,"ZC","")
.I PSOLPSTA'="",PSOLPSTA<10 D
..I +$P($G(^PSRX(PSOLPRX,2)),"^",6),+$P($G(^(2)),"^",6)<DT S $P(^PSRX(PSOLPRX,"STA"),"^")=11,PSOLPSTA=11
.S PSOLPSTX=$S(PSOLPSTA=3:"OH",PSOLPSTA=16:"OH",PSOLPSTA=12:"OD",PSOLPSTA=15:"OD",PSOLPSTA=14:"OD",1:"SC"),PSOLPSTZ=$S(PSOLPSTA=0:"CM",PSOLPSTA=1:"IP",PSOLPSTA=4:"IP",PSOLPSTA=5:"ZS",PSOLPSTA=11:"ZE",1:"")
.D EN^PSOHLSN1(PSOLPRX,PSOLPSTX,PSOLPSTZ,"")
S:$D(ZTQUEUED) ZTREQ="@"
PATCHQ Q
;
;PSO*186
DEACHK(PSIRXN,PSDEA,PSDAYS,PCLOZ,PSOCS,PSMAXRF) ;Apply DEA restrictions
;
; If no refills allowed indicate that and set Max refills to number
; of fills thus far, or if new order, then num of refills will not be
; found and Max refills will be 0.
;
; Function returns: 1 = no refills allowed
; Function returns: 2 = no refills allowed
; 0 = ok to refill
; Input Variables: PSIRXN = internal RX number or "*"=(new order)
; PSDEA = DEA special handling for drug ordered
; PSDAYS = Days supply ordered
; PCLOZ = Clozapine patient? (Optional)
; Output Variables: PSOCS = Controlled sub flag (Optional)
; PSMAXRF= Max Refill allowed by DEA restriction
; (Optional)
;
S PSIRXN=+$G(PSIRXN),PSDEA=$G(PSDEA),PSDAYS=+$G(PSDAYS)
S PSOCS=+$G(PSOCS),PSMAXRF=+$G(PSMAXRF),PCLOZ=$G(PCLOZ)
;
;if clozapine patient (passed in 0 or 1), set max refills and quit
I PCLOZ=0 S PSMAXRF=0 Q 1
I PCLOZ=1 S PSMAXRF=1 Q 0
;
;no refills if PSDEA = 'A' & not 'B' or 'F',
I (PSDEA["A")&(PSDEA'["B")!(PSDEA["F")!(PSDEA[1)!(PSDEA[2) D Q 2 ;*388
. S PSMAXRF=$$NUMFILLS(PSIRXN)
;
N QQ
F QQ=1:1 Q:$E(PSDEA,QQ)="" I $E(+PSDEA,QQ)>1,$E(+PSDEA,QQ)<6 D
. S PSOCS=1
. S:$E(+PSDEA,QQ)=2 $P(PSOCS,"^",2)=1
;
;no refills allowed on sched 2
I $P(PSOCS,"^",2)=1 S PSMAXRF=$$NUMFILLS(PSIRXN) Q 2 ;*388
;
; Checking past dispensed DAYS SUPPLY to make sure the refill does not exceed maximum allowed (PSO*7*444)
S PSDAYS=+$G(PSDAYS)
I PSOCS,$$TOTALDS+PSDAYS>184 Q 1
I 'PSOCS,$$TOTALDS+PSDAYS>365 Q 1
;
;set max refill for controlled substance & other based on days supply
I $G(PSIRXN) D
. S PSMAXRF=$$MAXNUMRF^PSOUTIL(+$P(^PSRX(PSIRXN,0),"^",6),PSDAYS,+$P(^PSRX(PSIRXN,0),"^",3))
E D
. I PSOCS D
. . I PSDAYS'>90 S PSMAXRF=$S(PSDAYS<60:5,PSDAYS'<60&(PSDAYS'>89):2,PSDAYS=90:1,1:0)
. . I PSDAYS>90 S PSMAXRF=182\PSDAYS-1
. E D
. . I PSDAYS'>90 S PSMAXRF=$S(PSDAYS<60:11,PSDAYS'<60&(PSDAYS'>89):5,PSDAYS=90:3,1:0)
. . I PSDAYS>90 S PSMAXRF=365\PSDAYS-1
;
;get number of fills if applies & compare to Max refills
N PNFILLS S PNFILLS=$$NUMFILLS(PSIRXN)
I PNFILLS'<PSMAXRF S PSMAXRF=PNFILLS Q 1
;
Q 0
;
NUMFILLS(PSIRXN) ;Return number of fills thus far, or 0 if doesn't apply
; function returns: if Active drug, then number of refills thus far
; else return 0 for does not apply
; Input Variables: PSIRXN = internal RX number (Optional)
Q:'$G(PSIRXN) 0
N RFN,RFNC
S (RFN,RFNC)=0
F S RFN=$O(^PSRX(PSIRXN,1,RFN)) Q:'RFN S RFNC=RFNC+1
Q RFNC
;
TOTALDS(RXIEN) ; Return the Total number of Days Supply for a prescription
; Input: RXIEN - PRESCRIPTION file (#52) IEN (Internal Entry Number)
;Output: TOTALDS - Sum of DAYS SUPPLY field from all Rx Fills (original + Refills only)
;
Q:'$G(RXIEN) 0
N TOTALDS,RXFILL
S TOTALDS=$$GET1^DIQ(52,RXIEN,8)
S RXFILL=0
F S RXFILL=$O(^PSRX(RXIEN,1,RXFILL)) Q:'RXFILL D
. S TOTALDS=TOTALDS+$$GET1^DIQ(52.1,RXFILL_","_RXIEN,1.1)
Q TOTALDS
;
REFIP(RXI,RFIL,TYP) ;Check if refill is Not Released and In Process and
; pending Auto Release by an external dispense machine.
; Input: RXI = internal Prescription no.
; RFIL= refill number
; TYP ="R"-refill or "P"-partial
; Returns 1 = In Process (Not OK to delete)
; 0 = Not In Process (OK to delete)
;
;assumes a refill is Not In Process by the external dispense machine
;unless it finds a record in this file and is marked to the contrary
;
N PSIEN,IP,FOUND,EXDATA,EXDIV
S (IP,FOUND)=0,PSIEN=""
;find first specified refill processing backwards, in case dupes
F S PSIEN=$O(^PS(52.51,"B",RXI,PSIEN),-1) Q:PSIEN="" D Q:FOUND
. S EXDATA=^PS(52.51,PSIEN,0)
. I $P(EXDATA,"^",9)=RFIL D
. . S EXDIV=$P(EXDATA,"^",11)
. . Q:'$P($G(^PS(59,EXDIV,"DISP")),"^",2) ;quit, not auto release
. . S FOUND=1
. I FOUND,$P(^PS(52.51,PSIEN,0),"^",10)'=2 S IP=1
Q IP
;
WARN1 ;partial del checks *259
N PSR,PSOL
S PSR=0 F S PSR=$O(^PSRX(DA(1),"P",PSR)) Q:'PSR S PSOL=PSR
I DA=PSOL,$P(^PSRX(DA(1),"P",DA,0),"^",19) D Q
.D EN^DDIOL("Partial Released! Use the 'Return to Stock' option!","","$C(7),!!"),EN^DDIOL(" ","","!")
;
;Warn of In Process, Only delete if answered Yes ;*259
I $$REFIP^PSOUTLA1(DA(1),DA,"P") D I 'Y Q ;reset $T
. D EN^DDIOL("** Partial refill has previously been sent to the External Dispense Machine","","!!,?2")
. D EN^DDIOL("** for filling and is still Pending Processing","","$C(7),!,?2")
. D EN^DDIOL("","","!")
. K DIR
. S DIR("A")="Do you want to continue? "
. S DIR("B")="Y"
. S DIR(0)="YA^^"
. S DIR("?")="Enter Y for Yes or N for No."
. D ^DIR
. K DIR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOUTLA1 10756 printed Apr 09, 2024@21:27:05 Page 2
PSOUTLA1 ;BHAM ISC/RTR-Pharmacy utility program cont. ; 17 Jun 2011 2:21 PM
+1 ;;7.0;OUTPATIENT PHARMACY;**35,186,218,259,206,388,444**;DEC 1997;Build 34
+2 ;External reference to File ^PS(55 supported by DBIA 2228
+3 ;External reference to File ^PSDRUG supported by DBIA 221
+4 ;External reference to File ^PS(59.7 supported by DBIA 694
+5 ;External reference to File ^PS(51 supported by DBIA 2224
+6 ;
+7 ;*186 - add DEACHK function
+8 ;*218 - add REFIP function
+9 ;*259 - reverse *218 delete restriction only warn of deleting
+10 ; also add del of last refill only
+11 ;
EN1 ;Formats condensed, back door sig in BSIG array
+1 ;pass in 1) Internal Rx from 52
+2 ; 2) max length of BSIG array
+3 ;Returned, still condensed, in BSIG array, when looping through, check for array=null, if so, juist don't print it
EN2(PSOBINTR,PSOBLGTH) ;
+1 KILL BSIG
+2 NEW BBSIG,BVAR,BVAR1,III,CNT,NNN,BLIM
+3 SET BBSIG=$PIECE($GET(^PSRX(PSOBINTR,"SIG")),"^")
if BBSIG=""!($PIECE($GET(^("SIG")),"^",2))
QUIT
+4 SET (BVAR,BVAR1)=""
SET III=1
+5 SET CNT=0
FOR NNN=1:1:$LENGTH(BBSIG)
IF $EXTRACT(BBSIG,NNN)=" "!($LENGTH(BBSIG)=NNN)
SET CNT=CNT+1
Begin DoDot:1
+6 SET BVAR1=$PIECE(BBSIG," ",(CNT))
+7 SET BLIM=BVAR
+8 SET BVAR=$SELECT(BVAR="":BVAR1,1:BVAR_" "_BVAR1)
End DoDot:1
IF $LENGTH(BVAR)>PSOBLGTH
SET BSIG(III)=BLIM_" "
SET III=III+1
SET BVAR=BVAR1
+9 IF $GET(BVAR)'=""
SET BSIG(III)=BVAR
+10 IF $GET(BSIG(1))=""!($GET(BSIG(1))=" ")
SET BSIG(1)=$GET(BSIG(2))
KILL BSIG(2)
+11 QUIT
+12 ;
EN3(PSOBINTR,PSOBLGTH) ;
+1 ;Pass in to EN3 the internal Rx number from 52, and the length of
+2 ;the array you want. Returns expanded Sig, or warning from PSOHELP
+3 ;concantenated with the condensed Sig in the BSIG array
+4 ;BACK DOOR ONLY
+5 KILL BSIG,X
NEW BBSIG,BVAR,BVAR1,III,CNT,NNN,BLIM,Y,SIG,Z0,Z1,BBWARN
+6 SET BBSIG=$PIECE($GET(^PSRX(PSOBINTR,"SIG")),"^")
if BBSIG=""!($PIECE($GET(^("SIG")),"^",2))
QUIT
+7 SET (SIG,X)=BBSIG
+8 IF $EXTRACT(BBSIG)=" "
SET BBWARN="Leading spaces are not allowed in the SIG!"
GOTO START
+9 SET SIG=""
if $LENGTH(X)<1
QUIT
FOR Z0=1:1:$LENGTH(X," ")
if Z0=""
GOTO START
SET Z1=$PIECE(X," ",Z0)
Begin DoDot:1
+10 IF $LENGTH(Z1)>32
SET BBWARN="MAX OF 32 CHARACTERS ALLOWED BETWEEN SPACES!"
KILL X
QUIT
+11 if $DATA(X)&($GET(Z1)]"")
Begin DoDot:2
+12 SET Y=$ORDER(^PS(51,"B",Z1,0))
if 'Y!($PIECE($GET(^PS(51,+Y,0)),"^",4)>1)
QUIT
SET Z1=$PIECE(^PS(51,Y,0),"^",2)
if '$DATA(^(9))
QUIT
SET Y=$PIECE(X," ",Z0-1)
SET Y=$EXTRACT(Y,$LENGTH(Y))
if Y>1
SET Z1=^(9)
End DoDot:2
SET SIG=SIG_" "_Z1
End DoDot:1
if '$DATA(X)
GOTO START
START ;
+1 SET BBSIG=$SELECT($GET(BBWARN)="":SIG,1:BBWARN_" "_BBSIG)
+2 SET (BVAR,BVAR1)=""
SET III=1
+3 SET CNT=0
FOR NNN=1:1:$LENGTH(BBSIG)
IF $EXTRACT(BBSIG,NNN)=" "!($LENGTH(BBSIG)=NNN)
SET CNT=CNT+1
Begin DoDot:1
+4 SET BVAR1=$PIECE(BBSIG," ",(CNT))
+5 SET BLIM=BVAR
+6 SET BVAR=$SELECT(BVAR="":BVAR1,1:BVAR_" "_BVAR1)
End DoDot:1
IF $LENGTH(BVAR)>PSOBLGTH
SET BSIG(III)=BLIM_" "
SET III=III+1
SET BVAR=BVAR1
+7 IF $GET(BVAR)'=""
SET BSIG(III)=BVAR
+8 IF $GET(BSIG(1))=""!($GET(BSIG(1))=" ")
SET BSIG(1)=$GET(BSIG(2))
KILL BSIG(2)
+9 QUIT
PATCH ;Allow sites to backfill more than what was done at install
+1 NEW PSOBACKL,PSOBACKI,PSOBACKS,PSOBACKB,PSOBACKD,PSOBACKA
+2 SET PSOBACKL=$ORDER(^PS(59.7,0))
SET PSOBACKI=$EXTRACT($PIECE($GET(^PS(59.7,+$GET(PSOBACKL),49.99)),"^",7),1,7)
+3 IF '$GET(PSOBACKI)
SET PSOBACKI=$PIECE($GET(^PS(59.7,+$GET(PSOBACKL),49.99)),"^",4)
+4 IF $GET(PSOBACKI)
SET Y=PSOBACKI
DO DD^%DT
SET PSOBACKS=Y
SET X1=PSOBACKI
SET X2=-120
DO C^%DTC
SET (Y,PSOBACKB)=X
DO DD^%DT
SET PSOBACKD=Y
+5 IF $GET(PSOBACKD)'=""
WRITE !!,"Your CPRS/Outpatient installation date is "_$GET(PSOBACKS)_","_" which",!,"means we have already backfilled all active prescriptions and all",!,"prescriptions canceled or expired after "_$GET(PSOBACKD)_"."
+6 IF $TEST
WRITE !!,"If you want to backfill orders that were canceled or expired prior to this",!,"date of "_$GET(PSOBACKD)_", enter an earlier date and those orders",!,"will be backfilled to CPRS.",!
+7 IF $GET(PSOBACKD)=""
WRITE !!,"We cannot determine the date of the CPRS/Outpatient installation.",!
+8 WRITE !,"If you choose to backfill more orders to CPRS by utilizing this option,",!,"we remind you that disk storage can be significantly affected, depending on",!,"how many orders are backfilled.",!
+9 KILL DIR
SET DIR(0)="Y"
SET DIR("B")="N"
SET DIR("A")="Do you want to backfill more prescriptions"
SET DIR("?")="Enter Yes to backfill prescriptions canceled or expired before "_$GET(PSOBACKD)
DO ^DIR
KILL DIR
IF Y'=1
WRITE !
GOTO PATCHQ
+10 WRITE !
SET %DT="AEPX"
SET %DT("A")="Enter Date to begin backfill: "
if $GET(PSOBACKB)
SET %DT(0)=-PSOBACKB
DO ^%DT
if Y<0!($DATA(DTOUT))
GOTO PATCHQ
SET PSOBACKA=$EXTRACT(Y,1,7)
+11 WRITE !
KILL ZTDTH
SET ZTSAVE("PSOBACKB")=""
SET ZTSAVE("PSOBACKA")=""
SET ZTRTN="PATCHR^PSOUTLA1"
SET ZTDESC="BACKFILL PRSCRIPTIONS TO CPRS"
SET ZTIO=""
DO ^%ZTLOAD
WRITE !
GOTO PATCHQ
PATCHR ;Begin task
+1 NEW PSOPAL,PSOLPD,PSOLPRX
+2 SET PSOBACKA=PSOBACKA-.01
+3 IF '$GET(PSOBACKB)
SET PSOBACKB=DT
+4 FOR PSOPAL=0:0
SET PSOPAL=$ORDER(^PS(55,PSOPAL))
if 'PSOPAL
QUIT
FOR PSOLPD=PSOBACKA:0
SET PSOLPD=$ORDER(^PS(55,PSOPAL,"P","A",PSOLPD))
if 'PSOLPD!(PSOLPD>PSOBACKB)
QUIT
FOR PSOLPRX=0:0
SET PSOLPRX=$ORDER(^PS(55,PSOPAL,"P","A",PSOLPD,PSOLPRX))
if 'PSOLPRX
QUIT
Begin DoDot:1
+5 IF $PIECE($GET(^PSRX(PSOLPRX,0)),"^")=""!('$PIECE($GET(^(0)),"^",2))!('$PIECE($GET(^(0)),"^",6))
QUIT
+6 IF $PIECE($GET(^PSRX(PSOLPRX,"OR1")),"^",2)
QUIT
+7 IF '$PIECE($GET(^PSRX(PSOLPRX,0)),"^",19)
Begin DoDot:2
+8 IF $PIECE($GET(^PSRX(PSOLPRX,"OR1")),"^")=""
IF +$GET(^PSDRUG(+$PIECE($GET(^PSRX(PSOLPRX,0)),"^",6),2))
SET $PIECE(^PSRX(PSOLPRX,"OR1"),"^")=+$GET(^PSDRUG(+$PIECE($GET(^PSRX(PSOLPRX,0)),"^",6),2))
+9 IF $PIECE($GET(^PSRX(PSOLPRX,0)),"^",10)'=""
IF $GET(^PSRX(PSOLPRX,"SIG"))']""
IF '$ORDER(^PSRX(PSOLPRX,"SIG1",0))
SET ^PSRX(PSOLPRX,"SIG")=$PIECE($GET(^PSRX(PSOLPRX,0)),"^",10)_"^"_0
SET $PIECE(^PSRX(PSOLPRX,0),"^",10)=""
+10 IF $PIECE($GET(^PSRX(PSOLPRX,"STA")),"^")=""
IF $PIECE($GET(^PSRX(PSOLPRX,0)),"^",15)'=""
SET $PIECE(^PSRX(PSOLPRX,"STA"),"^")=$PIECE($GET(^PSRX(PSOLPRX,0)),"^",15)
SET $PIECE(^PSRX(PSOLPRX,0),"^",15)=""
+11 SET $PIECE(^PSRX(PSOLPRX,0),"^",19)=1
End DoDot:2
+12 SET PSOLPSTA=$PIECE($GET(^PSRX(PSOLPRX,"STA")),"^")
if PSOLPSTA=""!(PSOLPSTA=13)!(PSOLPSTA=10)
QUIT
+13 DO EN^PSOHLSN1(PSOLPRX,"ZC","")
+14 IF PSOLPSTA'=""
IF PSOLPSTA<10
Begin DoDot:2
+15 IF +$PIECE($GET(^PSRX(PSOLPRX,2)),"^",6)
IF +$PIECE($GET(^(2)),"^",6)<DT
SET $PIECE(^PSRX(PSOLPRX,"STA"),"^")=11
SET PSOLPSTA=11
End DoDot:2
+16 SET PSOLPSTX=$SELECT(PSOLPSTA=3:"OH",PSOLPSTA=16:"OH",PSOLPSTA=12:"OD",PSOLPSTA=15:"OD",PSOLPSTA=14:"OD",1:"SC")
SET PSOLPSTZ=$SELECT(PSOLPSTA=0:"CM",PSOLPSTA=1:"IP",PSOLPSTA=4:"IP",PSOLPSTA=5:"ZS",PSOLPSTA=11:"ZE",1:"")
+17 DO EN^PSOHLSN1(PSOLPRX,PSOLPSTX,PSOLPSTZ,"")
End DoDot:1
+18 if $DATA(ZTQUEUED)
SET ZTREQ="@"
PATCHQ QUIT
+1 ;
+2 ;PSO*186
DEACHK(PSIRXN,PSDEA,PSDAYS,PCLOZ,PSOCS,PSMAXRF) ;Apply DEA restrictions
+1 ;
+2 ; If no refills allowed indicate that and set Max refills to number
+3 ; of fills thus far, or if new order, then num of refills will not be
+4 ; found and Max refills will be 0.
+5 ;
+6 ; Function returns: 1 = no refills allowed
+7 ; Function returns: 2 = no refills allowed
+8 ; 0 = ok to refill
+9 ; Input Variables: PSIRXN = internal RX number or "*"=(new order)
+10 ; PSDEA = DEA special handling for drug ordered
+11 ; PSDAYS = Days supply ordered
+12 ; PCLOZ = Clozapine patient? (Optional)
+13 ; Output Variables: PSOCS = Controlled sub flag (Optional)
+14 ; PSMAXRF= Max Refill allowed by DEA restriction
+15 ; (Optional)
+16 ;
+17 SET PSIRXN=+$GET(PSIRXN)
SET PSDEA=$GET(PSDEA)
SET PSDAYS=+$GET(PSDAYS)
+18 SET PSOCS=+$GET(PSOCS)
SET PSMAXRF=+$GET(PSMAXRF)
SET PCLOZ=$GET(PCLOZ)
+19 ;
+20 ;if clozapine patient (passed in 0 or 1), set max refills and quit
+21 IF PCLOZ=0
SET PSMAXRF=0
QUIT 1
+22 IF PCLOZ=1
SET PSMAXRF=1
QUIT 0
+23 ;
+24 ;no refills if PSDEA = 'A' & not 'B' or 'F',
+25 ;*388
IF (PSDEA["A")&(PSDEA'["B")!(PSDEA["F")!(PSDEA[1)!(PSDEA[2)
Begin DoDot:1
+26 SET PSMAXRF=$$NUMFILLS(PSIRXN)
End DoDot:1
QUIT 2
+27 ;
+28 NEW QQ
+29 FOR QQ=1:1
if $EXTRACT(PSDEA,QQ)=""
QUIT
IF $EXTRACT(+PSDEA,QQ)>1
IF $EXTRACT(+PSDEA,QQ)<6
Begin DoDot:1
+30 SET PSOCS=1
+31 if $EXTRACT(+PSDEA,QQ)=2
SET $PIECE(PSOCS,"^",2)=1
End DoDot:1
+32 ;
+33 ;no refills allowed on sched 2
+34 ;*388
IF $PIECE(PSOCS,"^",2)=1
SET PSMAXRF=$$NUMFILLS(PSIRXN)
QUIT 2
+35 ;
+36 ; Checking past dispensed DAYS SUPPLY to make sure the refill does not exceed maximum allowed (PSO*7*444)
+37 SET PSDAYS=+$GET(PSDAYS)
+38 IF PSOCS
IF $$TOTALDS+PSDAYS>184
QUIT 1
+39 IF 'PSOCS
IF $$TOTALDS+PSDAYS>365
QUIT 1
+40 ;
+41 ;set max refill for controlled substance & other based on days supply
+42 IF $GET(PSIRXN)
Begin DoDot:1
+43 SET PSMAXRF=$$MAXNUMRF^PSOUTIL(+$PIECE(^PSRX(PSIRXN,0),"^",6),PSDAYS,+$PIECE(^PSRX(PSIRXN,0),"^",3))
End DoDot:1
+44 IF '$TEST
Begin DoDot:1
+45 IF PSOCS
Begin DoDot:2
+46 IF PSDAYS'>90
SET PSMAXRF=$SELECT(PSDAYS<60:5,PSDAYS'<60&(PSDAYS'>89):2,PSDAYS=90:1,1:0)
+47 IF PSDAYS>90
SET PSMAXRF=182\PSDAYS-1
End DoDot:2
+48 IF '$TEST
Begin DoDot:2
+49 IF PSDAYS'>90
SET PSMAXRF=$SELECT(PSDAYS<60:11,PSDAYS'<60&(PSDAYS'>89):5,PSDAYS=90:3,1:0)
+50 IF PSDAYS>90
SET PSMAXRF=365\PSDAYS-1
End DoDot:2
End DoDot:1
+51 ;
+52 ;get number of fills if applies & compare to Max refills
+53 NEW PNFILLS
SET PNFILLS=$$NUMFILLS(PSIRXN)
+54 IF PNFILLS'<PSMAXRF
SET PSMAXRF=PNFILLS
QUIT 1
+55 ;
+56 QUIT 0
+57 ;
NUMFILLS(PSIRXN) ;Return number of fills thus far, or 0 if doesn't apply
+1 ; function returns: if Active drug, then number of refills thus far
+2 ; else return 0 for does not apply
+3 ; Input Variables: PSIRXN = internal RX number (Optional)
+4 if '$GET(PSIRXN)
QUIT 0
+5 NEW RFN,RFNC
+6 SET (RFN,RFNC)=0
+7 FOR
SET RFN=$ORDER(^PSRX(PSIRXN,1,RFN))
if 'RFN
QUIT
SET RFNC=RFNC+1
+8 QUIT RFNC
+9 ;
TOTALDS(RXIEN) ; Return the Total number of Days Supply for a prescription
+1 ; Input: RXIEN - PRESCRIPTION file (#52) IEN (Internal Entry Number)
+2 ;Output: TOTALDS - Sum of DAYS SUPPLY field from all Rx Fills (original + Refills only)
+3 ;
+4 if '$GET(RXIEN)
QUIT 0
+5 NEW TOTALDS,RXFILL
+6 SET TOTALDS=$$GET1^DIQ(52,RXIEN,8)
+7 SET RXFILL=0
+8 FOR
SET RXFILL=$ORDER(^PSRX(RXIEN,1,RXFILL))
if 'RXFILL
QUIT
Begin DoDot:1
+9 SET TOTALDS=TOTALDS+$$GET1^DIQ(52.1,RXFILL_","_RXIEN,1.1)
End DoDot:1
+10 QUIT TOTALDS
+11 ;
REFIP(RXI,RFIL,TYP) ;Check if refill is Not Released and In Process and
+1 ; pending Auto Release by an external dispense machine.
+2 ; Input: RXI = internal Prescription no.
+3 ; RFIL= refill number
+4 ; TYP ="R"-refill or "P"-partial
+5 ; Returns 1 = In Process (Not OK to delete)
+6 ; 0 = Not In Process (OK to delete)
+7 ;
+8 ;assumes a refill is Not In Process by the external dispense machine
+9 ;unless it finds a record in this file and is marked to the contrary
+10 ;
+11 NEW PSIEN,IP,FOUND,EXDATA,EXDIV
+12 SET (IP,FOUND)=0
SET PSIEN=""
+13 ;find first specified refill processing backwards, in case dupes
+14 FOR
SET PSIEN=$ORDER(^PS(52.51,"B",RXI,PSIEN),-1)
if PSIEN=""
QUIT
Begin DoDot:1
+15 SET EXDATA=^PS(52.51,PSIEN,0)
+16 IF $PIECE(EXDATA,"^",9)=RFIL
Begin DoDot:2
+17 SET EXDIV=$PIECE(EXDATA,"^",11)
+18 ;quit, not auto release
if '$PIECE($GET(^PS(59,EXDIV,"DISP")),"^",2)
QUIT
+19 SET FOUND=1
End DoDot:2
+20 IF FOUND
IF $PIECE(^PS(52.51,PSIEN,0),"^",10)'=2
SET IP=1
End DoDot:1
if FOUND
QUIT
+21 QUIT IP
+22 ;
WARN1 ;partial del checks *259
+1 NEW PSR,PSOL
+2 SET PSR=0
FOR
SET PSR=$ORDER(^PSRX(DA(1),"P",PSR))
if 'PSR
QUIT
SET PSOL=PSR
+3 IF DA=PSOL
IF $PIECE(^PSRX(DA(1),"P",DA,0),"^",19)
Begin DoDot:1
+4 DO EN^DDIOL("Partial Released! Use the 'Return to Stock' option!","","$C(7),!!")
DO EN^DDIOL(" ","","!")
End DoDot:1
QUIT
+5 ;
+6 ;Warn of In Process, Only delete if answered Yes ;*259
+7 ;reset $T
IF $$REFIP^PSOUTLA1(DA(1),DA,"P")
Begin DoDot:1
+8 DO EN^DDIOL("** Partial refill has previously been sent to the External Dispense Machine","","!!,?2")
+9 DO EN^DDIOL("** for filling and is still Pending Processing","","$C(7),!,?2")
+10 DO EN^DDIOL("","","!")
+11 KILL DIR
+12 SET DIR("A")="Do you want to continue? "
+13 SET DIR("B")="Y"
+14 SET DIR(0)="YA^^"
+15 SET DIR("?")="Enter Y for Yes or N for No."
+16 DO ^DIR
+17 KILL DIR
End DoDot:1
IF 'Y
QUIT
+18 QUIT
