PSOPRKA ;BIR/EJW - PARK/UNPARK functionality (cont.) ; Apr 24, 2023@08:17:57
;;7.0;OUTPATIENT PHARMACY;**441,712**;DEC 1997;Build 20
;
; Reference to $$L^PSSLOCK,PSOL^PSSLOCK,PSOUL^PSSLOCK,UL^PSSLOCK in ICR #2789
;(modified from hold rtn PSOHLDA)
;NOTE for PaPI - check on ECME calls like in the PSOHLD* routines (e.g. reverse
; below may need another code besides "HLD" for parking)
;
PARK(PSODA) ;park function ; Called from PSOPRK and edit for Outpatient and from PSORPC01 for Park from CPRS
S (DA,PSDA)=PSODA
N RXF,NEXTPOSS,BPMW,PRKMW,PSOOLDFILLDT
I $P($G(^PSRX(DA,"STA")),"^")'=0,$P($G(^PSRX(DA,"STA")),"^")'=5 Q ; can't park unless active
S RSDT=$S($P(^PSRX(DA,2),"^",13):$P(^PSRX(DA,3),"^"),1:"@"),(PSUS,ACT,RXF,RFN,I)=0 F S I=$O(^PSRX(DA,1,I)) Q:'I D
.S RXF=I,RFN=RFN+1 S:RFN=1 RSDT=$S('$P(^PSRX(DA,1,I,0),"^",18):$P(^PSRX(DA,2),"^",2),1:$P(^PSRX(DA,1,I,0),"^"))
.I RFN>1,'$P(^PSRX(DA,1,I,0),"^",18) S RSDT=$P(^PSRX(DA,1,RXF-1,0),"^") Q
.S:RFN>1 RSDT=$P(^PSRX(DA,1,RXF,0),"^")
; FILL DATE (FLD 22),2;13=RELEASED STATUS (FLD 100),LAST DISPENSED DT (FLD 101)
S PSOOLDFILLDT=$S(RXF:$P(^PSRX(DA,1,RXF,0),U,1),1:$P(^PSRX(DA,2),U,2))
S NEXTPOSS=$P(^PSRX(DA,3),"^",2)
S BPMW=$S('RXF&$G(PSOTOPK)&($P($G(PSORXED("RX0")),U,11)'=""):$P(PSORXED("RX0"),U,11),'RXF:$P(^PSRX(DA,0),U,11),RXF:$P(^PSRX(DA,1,RXF,0),U,2),1:"")
I 'RXF,'$P(^PSRX(DA,2),"^",13) S NEXTPOSS=$P(^PSRX(DA,2),"^",2) ; SET NEXT POSSIBLE TO FILL DATE THAT IS BEING BLANKED OUT WHEN PARKED
S DIE="^PSRX(",DR=$S('RXF&($$CHKPRKORIG(DA)):"22///@;",1:"")_"100///0;101///"_RSDT_";102///"_NEXTPOSS D ^DIE Q:$D(Y)
S ^PSRX(DA,"PARK")=1,^PSRX("APARK",1,DA)="",$P(^PSRX(DA,"STA"),"^")=0
D:$D(PSORX("PSOL")) RMP(DA)
K BINGRTE ; DON'T GO TO BINGO BOARD IF PARKED
S PRKMW="P"
I 'RXF N DA,DIE,DR S DA=PSDA,DIE="^PSRX(",DR="11///"_PRKMW D ^DIE
I RXF N DA,DIE,DR S DA(1)=PSDA,DA=RXF,DIE="^PSRX("_DA(1)_",1,",DR="2///"_PRKMW D ^DIE S DA=PSDA
S VALMSG="RX# "_$P(^PSRX(DA,0),"^")_" placed in Active/Parked status."
K RXRS(DA)
; REMOVE FROM SUSPENSE WHEN PARKED
I +$G(PSDA) S DA=$O(^PS(52.5,"B",PSDA,0)) I DA S:$P($G(^PS(52.5,DA,"P")),"^")=0 PSUS=1 S DIK="^PS(52.5," D ^DIK K DA,DIK
S:+$G(PSDA) DA=PSDA D RXACT^PSOPRK(DA,"PK",,,PSUS)
N PSONOOR,COMM
S COMM="Medication placed in Active/Parked status "_$E(DT,4,5)_"-"_$E(DT,6,7)_"-"_$E(DT,2,3)
S PSONOOR="I" ; DEFAULT TO "POLICY" FOR PARK/UNPARK
HL7 D EN^PSOHLSN1(DA,"SC","",COMM,PSONOOR)
;
; - Closes any OPEN/UNRESOLVED REJECTs and Reverses ECME Claim
D REVERSE^PSOBPSU1(DA,+$G(RXF),"HLD",2)
;
K PSUS,RXF,I,FDA,DIC,DIE,DR,Y,X,%,%I,%H,RSDT
Q
;
RMP(PSODA) ;remove Rx if found in array PSORX("PSOL")
Q:'$G(PSODA)
N I,J,K,PSOX2,PSOX3,PSOX9 S I=0
F S I=$O(PSORX("PSOL",I)) Q:'I S PSOX2=PSORX("PSOL",I) D:PSOX2[(PSODA_",")
.S PSOX9="",K=0 F J=1:1 S PSOX3=$P(PSOX2,",",J) Q:'PSOX3 D
..I PSOX3=PSODA,$P($G(^PSRX(PSODA,"STA")),"^")=0 S K=1 Q
..S PSOX9=PSOX9_$S('PSOX9:"",1:",")_PSOX3
.I K S:PSOX9]"" PSORX("PSOL",I)=PSOX9_"," K:PSOX9="" PSORX("PSOL",I) D:$D(BBRX(I)) RMB(PSODA)
Q
RMB(PSODA) ;remove Rx if found in array BBRX()
S PSOX2=BBRX(I) D:PSOX2[(PSODA_",")
.S PSOX9="" F J=1:1 S PSOX3=$P(PSOX2,",",J) Q:'PSOX3 S:PSOX3'=PSODA PSOX9=PSOX9_$S('PSOX9:"",1:",")_PSOX3
.S:PSOX9]"" BBRX(I)=PSOX9_"," K:PSOX9="" BBRX(I)
Q
;
UNPARK(PSODA,PSODFN,ERRMSG,PSOARR) ; UNPARK FROM CPRS and refill option (including AudioCARE
; Process telephone refills option)
; Called from CPRS (PSORPC01 RPC) (Marks as unparked and queues fill to
; suspense if last fill is unreleased and label has not printed. If last fill
; is released, do auto refill.)
N RXIEN,PSOX,STA,PSOY,PSORXFL,PSOFILNM,PSOOLDFILLDT
S (DA,PSORXFL,PSOFILNM)=PSODA
S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY S ERRMSG(1)=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.") K PSOPLCK S VALMBCK="" Q
K PSOPLCK D PSOL^PSSLOCK(DA) I '$G(PSOMSG) S ERRMSG(1)=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),VALMBCK="" K PSOMSG D ULP Q
S STA=+$G(^PSRX(DA,"STA")) I STA'=0!('$G(^PSRX(DA,"PARK"))) S ERRMSG(1)="Cannot unpark. Order is not parked." D ULP Q
K DIR,DTOUT,DUOUT,DIRUT
EN ;
N I,UNRFIL
S (RXF,UNRFIL)=0 F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I S RXF=I
S RSDT="",LBLP=0
D GETRELDT(DA)
I 'RSDT D CHKLBL(DA,RXF) ; if not released, but label has printed or sent to CMOP, order new refill if available.
; If label has not printed and latest fill is not released and not sent to CMOP, process it instead of ordering new
I 'RSDT,'LBLP D ^PSOCMOPA
; Unpark whether reusing fill or not
D KILLPARK^PSOPRK(DA)
I 'RSDT,'LBLP,'$D(PSOCMOP) D ; If last fill not released and label not printed, put it on suspense with routing of mail when unparked; reset dates
.I RXF S PSORX("FILL DATE")=$P(^PSRX(DA,1,RXF,0),"^")
.I 'RXF S PSORX("FILL DATE")=$P(^PSRX(DA,3),"^",2)
.I PSORX("FILL DATE")<DT S PSORX("FILL DATE")=DT
.S PSOOLDFILLDT=$S(RXF:$P(^PSRX(DA,1,RXF,0),"^",1),1:$P(^PSRX(DA,2),"^",2))
.D UPKSUSP
.S UNRFIL=1
D RXACT^PSOPRK(DA,"UPK") S PSOKPK=$G(PSOKPK)+1
I '$G(UNRFIL),$S('RXF:$P(^PSRX(DA,0),"^",11),RXF:$P(^PSRX(DA,1,RXF,0),"^",2),1:"")="P" D
.N I,J,BPMW S I=0,BPMW=""
.F S I=$O(^PSRX(DA,"A",I)) Q:'I S J=^(I,0) I $P(J,"^",4)=RXF,J["Rx placed in Parked status" S BPMW=$S(J["(M)":"M",J["(W)":"W",1:"M")
.I BPMW]"" S:'RXF $P(^PSRX(DA,0),"^",11)=BPMW S:RXF $P(^PSRX(DA,1,RXF,0),"^",2)=BPMW
S:$G(ORRFILL)&('$G(UNRFIL)) UNPARK=0
S:$G(ORRFILL)&($G(UNRFIL)) UNPARK=1
I $G(ORRFILL)!$G(UNRFIL) G EN0
I RSDT!(LBLP)!($D(PSOCMOP)) D ; If latest fill released or label printed, generate new refill using autorefill logic
.K ERRMSG
.D REFRX(.PSOERR)
.I $G(PSOERR(1))'="" S ERRMSG(1)="Unparked. "_PSOERR(1) ; Message back to CPRS if couldn't refill
;
EN0 ;
D ULP
EX D PSOUL^PSSLOCK(RXIEN)
K PSOHRL,PSOMSG,PSOPLCK,ST,PSL,PSNP,IR,NOW,DR,NEW1,NEW11,RTN,DA,PPL,RXN,RX0,RXS,DIK,RXP,FLD,ACT,DIE,DIC,DIR,DIE,X,Y,DIRUT,DUOUT,SUSPT,C,D0,LFD,I,PSDA,RFDATE,DI,DQ,%,RFN,XFLAG
K HRX,PSPRK,PSOLIST,STA,QTY,RFDT,PSORX0,PSRXN,RXF,JJ,PSOERR
K PSOUTIL,PSOX,PSOY,RSDT,RXIEN,SITE
;
Q
;
ULP ;
D UL^PSSLOCK(+$G(PSODFN))
Q
;
REFRX(REFCOM) ;
I $O(^PS(52.41,"ARF",PSORXFL,0)) S REFCOM(1)="Refill request already exists." Q
I '$D(^PSRX(PSORXFL,0)) S REFCOM(1)="Order was not located by Pharmacy." Q
I $G(PDFN),$G(PDFN)'=$P($G(^PSRX(PSORXFL,0)),"^",2) S REFCOM(1)="Patient does not match." Q
;
; Unpark released fill -> Auto Refill, file to Prescription file #52 and put on suspense
D REF^PSOATRFC(PSOFILNM,.PSOERR)
I $G(PSOERR(1))'="" S REFCOM(1)=PSOERR(1)
Q
;
UPKSUSP ; Update routing and date fields for latest fill and put on suspense
N PSOX,NEXTPOSS,FILLDATE,SD
S PSOX("RX0")=^PSRX(PSODA,0)
S PSOX("RX2")=$G(^PSRX(PSODA,2))
S PSOX("QTY")=$P(PSOX("RX0"),"^",7),PSOX("DAYS SUPPLY")=$P(PSOX("RX0"),"^",8)
S X1=PSORX("FILL DATE"),X2=PSOX("DAYS SUPPLY")-10\1 D C^%DTC S PSOX1=X
S FILLDATE=PSORX("FILL DATE")
S NEXTPOSS=PSOX1
K X,PSOX1
S PSOX("MAIL/WINDOW")="M"
S DIE="^PSRX(",DR=$S('RXF:"22////"_FILLDATE_";",1:"")_"100///5;102///"_NEXTPOSS D ^DIE
I RXF N DA,DIE,DR S DA(1)=PSODA,DA=RXF,DIE="^PSRX("_DA(1)_",1,",DR=".01////"_FILLDATE D ^DIE
S PRKMW="M"
I 'RXF N DA,DIE,DR S DA=PSODA,DIE="^PSRX(",DR="11///"_PRKMW D ^DIE
I RXF N DA,DIE,DR S DA(1)=PSODA,DA=RXF,DIE="^PSRX("_DA(1)_",1,",DR="2///"_PRKMW D ^DIE S DA=PSODA
S $P(^PSRX(PSODA,3),"^")=FILLDATE
; PUT ON SUSPENSE
S (RXN,DA)=PSODA
S SD=FILLDATE
I '$G(PSOSITE) N PSOSITE S PSOSITE=$$RXSITE^PSOBPSUT(RXN,$G(RXF))
S RXP=+$G(RXPR(DA)),DIC="^PS(52.5,",DIC(0)="L",X=RXN,DIC("DR")=".02///"_SD_";.03////"_$P(^PSRX(DA,0),"^",2)_";.04///M;.05///"_RXP_";.06////"_PSOSITE_";2///0" K DD,DO D FILE^DICN D I +Y,'$G(RXP),$G(RXRP(RXN)) S $P(^PS(52.5,+Y,0),"^",12)=1
.K DD,DO I +Y,$G(PSOEXREP) S $P(^PS(52.5,+Y,0),"^",12)=1
.I +Y S $P(^PS(52.5,+Y,0),"^",13)=$G(RXF)
S $P(^PSRX(RXN,"STA"),"^")=5,LFD=$E(SD,4,5)_"-"_$E(SD,6,7)_"-"_$E(SD,2,3)
S PSOARR("UPKSUSPCOMM")=$G(RXF)_" Susp. until "_$TR(LFD,"-","/")
D ACT^PSORXL1
S COMM=$S(RXP:"Partial ",1:"")_"Rx# "_$P(^PSRX(RXN,0),"^")_" Has Been Suspended Until "_LFD_"."_$S($G(RXRP(RXN))&('$G(RXP)):" (Reprint)",1:"")
D EN^PSOHLSN1(RXN,"SC","ZS",COMM)
Q
;
GETRELDT(DA) ; get release date of last fill
N I,RXF
S RXF=0 F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I S RXF=I,RSDT=$P(^(I,0),"^",18)
S RXIEN=DA
I 'RXF S RSDT=$P(^PSRX(DA,2),"^",13)
Q
;
CHKLBL(PSODA,RXF) ; see if label has printed for this fill
N LBL
S LBLP=0
F LBL=0:0 S LBL=$O(^PSRX(PSODA,"L",LBL)) Q:'LBL I $P(^PSRX(PSODA,"L",LBL,0),"^",2)=RXF S LBLP=1
Q
;
CHKPARK(DA,RESULT) ; Entry point for AudioCARE API to determine if parked original/refill
; with no refills can be requested now (will queue original/refill when refill request is received)
N PSOPRKRF,PSORXF
S (LBLP,RESULT)=0
I '$D(^PSRX(DA)) Q
I '$G(^PSRX(DA,"PARK")) Q ; Not Parked
I +$G(^PSRX(DA,"STA"))'=0 Q ; Not Active
S PSOPRKRF=$O(^PSRX(DA,1,""))
I PSOPRKRF="",+$P(^PSRX(DA,0),"^",9)=0 D ;Check Original Fill
.D GETRELDT(DA) I 'RSDT D CHKLBL(DA,0) I 'LBLP D
..S NEXTPOSS=$P(^PSRX(DA,3),"^",2) I NEXTPOSS<DT S NEXTPOSS=DT
..D ^PSOCMOPA I '$D(PSOCMOP) S RESULT="1^"_NEXTPOSS
I PSOPRKRF'="",+$P(^PSRX(DA,0),"^",9)>0 D ;Check Last Refill
.S PSORXF=$O(^PSRX(DA,1,99999),-1)
.D GETRELDT(DA) I 'RSDT D CHKLBL(DA,PSORXF) I 'LBLP D
..S NEXTPOSS=$P(^PSRX(DA,3),"^",2) I NEXTPOSS<DT S NEXTPOSS=DT
..D ^PSOCMOPA I '$D(PSOCMOP) S RESULT="1^"_NEXTPOSS
K PSOCMOP,LBLP,RSDT,NEXTPOSS
Q
;
;
CHKPRKORIG(DA) ;
N PSOCMOP,LBLP,RSDT
I $O(^PSRX(DA,1,0)) Q 0
D GETRELDT(DA) I $G(RSDT) Q 0
D CHKLBL(DA,0) I $G(LBLP) Q 0
D ^PSOCMOPA I $D(PSOCMOP) Q 0
Q 1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOPRKA 9847 printed Apr 09, 2024@21:31:05 Page 2
PSOPRKA ;BIR/EJW - PARK/UNPARK functionality (cont.) ; Apr 24, 2023@08:17:57
+1 ;;7.0;OUTPATIENT PHARMACY;**441,712**;DEC 1997;Build 20
+2 ;
+3 ; Reference to $$L^PSSLOCK,PSOL^PSSLOCK,PSOUL^PSSLOCK,UL^PSSLOCK in ICR #2789
+4 ;(modified from hold rtn PSOHLDA)
+5 ;NOTE for PaPI - check on ECME calls like in the PSOHLD* routines (e.g. reverse
+6 ; below may need another code besides "HLD" for parking)
+7 ;
PARK(PSODA) ;park function ; Called from PSOPRK and edit for Outpatient and from PSORPC01 for Park from CPRS
+1 SET (DA,PSDA)=PSODA
+2 NEW RXF,NEXTPOSS,BPMW,PRKMW,PSOOLDFILLDT
+3 ; can't park unless active
IF $PIECE($GET(^PSRX(DA,"STA")),"^")'=0
IF $PIECE($GET(^PSRX(DA,"STA")),"^")'=5
QUIT
+4 SET RSDT=$SELECT($PIECE(^PSRX(DA,2),"^",13):$PIECE(^PSRX(DA,3),"^"),1:"@")
SET (PSUS,ACT,RXF,RFN,I)=0
FOR
SET I=$ORDER(^PSRX(DA,1,I))
if 'I
QUIT
Begin DoDot:1
+5 SET RXF=I
SET RFN=RFN+1
if RFN=1
SET RSDT=$SELECT('$PIECE(^PSRX(DA,1,I,0),"^",18):$PIECE(^PSRX(DA,2),"^",2),1:$PIECE(^PSRX(DA,1,I,0),"^"))
+6 IF RFN>1
IF '$PIECE(^PSRX(DA,1,I,0),"^",18)
SET RSDT=$PIECE(^PSRX(DA,1,RXF-1,0),"^")
QUIT
+7 if RFN>1
SET RSDT=$PIECE(^PSRX(DA,1,RXF,0),"^")
End DoDot:1
+8 ; FILL DATE (FLD 22),2;13=RELEASED STATUS (FLD 100),LAST DISPENSED DT (FLD 101)
+9 SET PSOOLDFILLDT=$SELECT(RXF:$PIECE(^PSRX(DA,1,RXF,0),U,1),1:$PIECE(^PSRX(DA,2),U,2))
+10 SET NEXTPOSS=$PIECE(^PSRX(DA,3),"^",2)
+11 SET BPMW=$SELECT('RXF&$GET(PSOTOPK)&($PIECE($GET(PSORXED("RX0")),U,11)'=""):$PIECE(PSORXED("RX0"),U,11),'RXF:$PIECE(^PSRX(DA,0),U,11),RXF:$PIECE(^PSRX(DA,1,RXF,0),U,2),1:"")
+12 ; SET NEXT POSSIBLE TO FILL DATE THAT IS BEING BLANKED OUT WHEN PARKED
IF 'RXF
IF '$PIECE(^PSRX(DA,2),"^",13)
SET NEXTPOSS=$PIECE(^PSRX(DA,2),"^",2)
+13 SET DIE="^PSRX("
SET DR=$SELECT('RXF&($$CHKPRKORIG(DA)):"22///@;",1:"")_"100///0;101///"_RSDT_";102///"_NEXTPOSS
DO ^DIE
if $DATA(Y)
QUIT
+14 SET ^PSRX(DA,"PARK")=1
SET ^PSRX("APARK",1,DA)=""
SET $PIECE(^PSRX(DA,"STA"),"^")=0
+15 if $DATA(PSORX("PSOL"))
DO RMP(DA)
+16 ; DON'T GO TO BINGO BOARD IF PARKED
KILL BINGRTE
+17 SET PRKMW="P"
+18 IF 'RXF
NEW DA,DIE,DR
SET DA=PSDA
SET DIE="^PSRX("
SET DR="11///"_PRKMW
DO ^DIE
+19 IF RXF
NEW DA,DIE,DR
SET DA(1)=PSDA
SET DA=RXF
SET DIE="^PSRX("_DA(1)_",1,"
SET DR="2///"_PRKMW
DO ^DIE
SET DA=PSDA
+20 SET VALMSG="RX# "_$PIECE(^PSRX(DA,0),"^")_" placed in Active/Parked status."
+21 KILL RXRS(DA)
+22 ; REMOVE FROM SUSPENSE WHEN PARKED
+23 IF +$GET(PSDA)
SET DA=$ORDER(^PS(52.5,"B",PSDA,0))
IF DA
if $PIECE($GET(^PS(52.5,DA,"P")),"^")=0
SET PSUS=1
SET DIK="^PS(52.5,"
DO ^DIK
KILL DA,DIK
+24 if +$GET(PSDA)
SET DA=PSDA
DO RXACT^PSOPRK(DA,"PK",,,PSUS)
+25 NEW PSONOOR,COMM
+26 SET COMM="Medication placed in Active/Parked status "_$EXTRACT(DT,4,5)_"-"_$EXTRACT(DT,6,7)_"-"_$EXTRACT(DT,2,3)
+27 ; DEFAULT TO "POLICY" FOR PARK/UNPARK
SET PSONOOR="I"
HL7 DO EN^PSOHLSN1(DA,"SC","",COMM,PSONOOR)
+1 ;
+2 ; - Closes any OPEN/UNRESOLVED REJECTs and Reverses ECME Claim
+3 DO REVERSE^PSOBPSU1(DA,+$GET(RXF),"HLD",2)
+4 ;
+5 KILL PSUS,RXF,I,FDA,DIC,DIE,DR,Y,X,%,%I,%H,RSDT
+6 QUIT
+7 ;
RMP(PSODA) ;remove Rx if found in array PSORX("PSOL")
+1 if '$GET(PSODA)
QUIT
+2 NEW I,J,K,PSOX2,PSOX3,PSOX9
SET I=0
+3 FOR
SET I=$ORDER(PSORX("PSOL",I))
if 'I
QUIT
SET PSOX2=PSORX("PSOL",I)
if PSOX2[(PSODA_",")
Begin DoDot:1
+4 SET PSOX9=""
SET K=0
FOR J=1:1
SET PSOX3=$PIECE(PSOX2,",",J)
if 'PSOX3
QUIT
Begin DoDot:2
+5 IF PSOX3=PSODA
IF $PIECE($GET(^PSRX(PSODA,"STA")),"^")=0
SET K=1
QUIT
+6 SET PSOX9=PSOX9_$SELECT('PSOX9:"",1:",")_PSOX3
End DoDot:2
+7 IF K
if PSOX9]""
SET PSORX("PSOL",I)=PSOX9_","
if PSOX9=""
KILL PSORX("PSOL",I)
if $DATA(BBRX(I))
DO RMB(PSODA)
End DoDot:1
+8 QUIT
RMB(PSODA) ;remove Rx if found in array BBRX()
+1 SET PSOX2=BBRX(I)
if PSOX2[(PSODA_",")
Begin DoDot:1
+2 SET PSOX9=""
FOR J=1:1
SET PSOX3=$PIECE(PSOX2,",",J)
if 'PSOX3
QUIT
if PSOX3'=PSODA
SET PSOX9=PSOX9_$SELECT('PSOX9:"",1:",")_PSOX3
+3 if PSOX9]""
SET BBRX(I)=PSOX9_","
if PSOX9=""
KILL BBRX(I)
End DoDot:1
+4 QUIT
+5 ;
UNPARK(PSODA,PSODFN,ERRMSG,PSOARR) ; UNPARK FROM CPRS and refill option (including AudioCARE
+1 ; Process telephone refills option)
+2 ; Called from CPRS (PSORPC01 RPC) (Marks as unparked and queues fill to
+3 ; suspense if last fill is unreleased and label has not printed. If last fill
+4 ; is released, do auto refill.)
+5 NEW RXIEN,PSOX,STA,PSOY,PSORXFL,PSOFILNM,PSOOLDFILLDT
+6 SET (DA,PSORXFL,PSOFILNM)=PSODA
+7 SET PSOPLCK=$$L^PSSLOCK(PSODFN,0)
IF '$GET(PSOPLCK)
DO LOCK^PSOORCPY
SET ERRMSG(1)=$SELECT($PIECE($GET(PSOPLCK),"^",2)'="":$PIECE($GET(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.")
KILL PSOPLCK
SET VALMBCK=""
QUIT
+8 KILL PSOPLCK
DO PSOL^PSSLOCK(DA)
IF '$GET(PSOMSG)
SET ERRMSG(1)=$SELECT($PIECE($GET(PSOMSG),"^",2)'="":$PIECE($GET(PSOMSG),"^",2),1:"Another person is editing this order.")
SET VALMBCK=""
KILL PSOMSG
DO ULP
QUIT
+9 SET STA=+$GET(^PSRX(DA,"STA"))
IF STA'=0!('$GET(^PSRX(DA,"PARK")))
SET ERRMSG(1)="Cannot unpark. Order is not parked."
DO ULP
QUIT
+10 KILL DIR,DTOUT,DUOUT,DIRUT
EN ;
+1 NEW I,UNRFIL
+2 SET (RXF,UNRFIL)=0
FOR I=0:0
SET I=$ORDER(^PSRX(DA,1,I))
if 'I
QUIT
SET RXF=I
+3 SET RSDT=""
SET LBLP=0
+4 DO GETRELDT(DA)
+5 ; if not released, but label has printed or sent to CMOP, order new refill if available.
IF 'RSDT
DO CHKLBL(DA,RXF)
+6 ; If label has not printed and latest fill is not released and not sent to CMOP, process it instead of ordering new
+7 IF 'RSDT
IF 'LBLP
DO ^PSOCMOPA
+8 ; Unpark whether reusing fill or not
+9 DO KILLPARK^PSOPRK(DA)
+10 ; If last fill not released and label not printed, put it on suspense with routing of mail when unparked; reset dates
IF 'RSDT
IF 'LBLP
IF '$DATA(PSOCMOP)
Begin DoDot:1
+11 IF RXF
SET PSORX("FILL DATE")=$PIECE(^PSRX(DA,1,RXF,0),"^")
+12 IF 'RXF
SET PSORX("FILL DATE")=$PIECE(^PSRX(DA,3),"^",2)
+13 IF PSORX("FILL DATE")<DT
SET PSORX("FILL DATE")=DT
+14 SET PSOOLDFILLDT=$SELECT(RXF:$PIECE(^PSRX(DA,1,RXF,0),"^",1),1:$PIECE(^PSRX(DA,2),"^",2))
+15 DO UPKSUSP
+16 SET UNRFIL=1
End DoDot:1
+17 DO RXACT^PSOPRK(DA,"UPK")
SET PSOKPK=$GET(PSOKPK)+1
+18 IF '$GET(UNRFIL)
IF $SELECT('RXF:$PIECE(^PSRX(DA,0),"^",11),RXF:$PIECE(^PSRX(DA,1,RXF,0),"^",2),1:"")="P"
Begin DoDot:1
+19 NEW I,J,BPMW
SET I=0
SET BPMW=""
+20 FOR
SET I=$ORDER(^PSRX(DA,"A",I))
if 'I
QUIT
SET J=^(I,0)
IF $PIECE(J,"^",4)=RXF
IF J["Rx placed in Parked status"
SET BPMW=$SELECT(J["(M)":"M",J["(W)":"W",1:"M")
+21 IF BPMW]""
if 'RXF
SET $PIECE(^PSRX(DA,0),"^",11)=BPMW
if RXF
SET $PIECE(^PSRX(DA,1,RXF,0),"^",2)=BPMW
End DoDot:1
+22 if $GET(ORRFILL)&('$GET(UNRFIL))
SET UNPARK=0
+23 if $GET(ORRFILL)&($GET(UNRFIL))
SET UNPARK=1
+24 IF $GET(ORRFILL)!$GET(UNRFIL)
GOTO EN0
+25 ; If latest fill released or label printed, generate new refill using autorefill logic
IF RSDT!(LBLP)!($DATA(PSOCMOP))
Begin DoDot:1
+26 KILL ERRMSG
+27 DO REFRX(.PSOERR)
+28 ; Message back to CPRS if couldn't refill
IF $GET(PSOERR(1))'=""
SET ERRMSG(1)="Unparked. "_PSOERR(1)
End DoDot:1
+29 ;
EN0 ;
+1 DO ULP
EX DO PSOUL^PSSLOCK(RXIEN)
+1 KILL PSOHRL,PSOMSG,PSOPLCK,ST,PSL,PSNP,IR,NOW,DR,NEW1,NEW11,RTN,DA,PPL,RXN,RX0,RXS,DIK,RXP,FLD,ACT,DIE,DIC,DIR,DIE,X,Y,DIRUT,DUOUT,SUSPT,C,D0,LFD,I,PSDA,RFDATE,DI,DQ,%,RFN,XFLAG
+2 KILL HRX,PSPRK,PSOLIST,STA,QTY,RFDT,PSORX0,PSRXN,RXF,JJ,PSOERR
+3 KILL PSOUTIL,PSOX,PSOY,RSDT,RXIEN,SITE
+4 ;
+5 QUIT
+6 ;
ULP ;
+1 DO UL^PSSLOCK(+$GET(PSODFN))
+2 QUIT
+3 ;
REFRX(REFCOM) ;
+1 IF $ORDER(^PS(52.41,"ARF",PSORXFL,0))
SET REFCOM(1)="Refill request already exists."
QUIT
+2 IF '$DATA(^PSRX(PSORXFL,0))
SET REFCOM(1)="Order was not located by Pharmacy."
QUIT
+3 IF $GET(PDFN)
IF $GET(PDFN)'=$PIECE($GET(^PSRX(PSORXFL,0)),"^",2)
SET REFCOM(1)="Patient does not match."
QUIT
+4 ;
+5 ; Unpark released fill -> Auto Refill, file to Prescription file #52 and put on suspense
+6 DO REF^PSOATRFC(PSOFILNM,.PSOERR)
+7 IF $GET(PSOERR(1))'=""
SET REFCOM(1)=PSOERR(1)
+8 QUIT
+9 ;
UPKSUSP ; Update routing and date fields for latest fill and put on suspense
+1 NEW PSOX,NEXTPOSS,FILLDATE,SD
+2 SET PSOX("RX0")=^PSRX(PSODA,0)
+3 SET PSOX("RX2")=$GET(^PSRX(PSODA,2))
+4 SET PSOX("QTY")=$PIECE(PSOX("RX0"),"^",7)
SET PSOX("DAYS SUPPLY")=$PIECE(PSOX("RX0"),"^",8)
+5 SET X1=PSORX("FILL DATE")
SET X2=PSOX("DAYS SUPPLY")-10\1
DO C^%DTC
SET PSOX1=X
+6 SET FILLDATE=PSORX("FILL DATE")
+7 SET NEXTPOSS=PSOX1
+8 KILL X,PSOX1
+9 SET PSOX("MAIL/WINDOW")="M"
+10 SET DIE="^PSRX("
SET DR=$SELECT('RXF:"22////"_FILLDATE_";",1:"")_"100///5;102///"_NEXTPOSS
DO ^DIE
+11 IF RXF
NEW DA,DIE,DR
SET DA(1)=PSODA
SET DA=RXF
SET DIE="^PSRX("_DA(1)_",1,"
SET DR=".01////"_FILLDATE
DO ^DIE
+12 SET PRKMW="M"
+13 IF 'RXF
NEW DA,DIE,DR
SET DA=PSODA
SET DIE="^PSRX("
SET DR="11///"_PRKMW
DO ^DIE
+14 IF RXF
NEW DA,DIE,DR
SET DA(1)=PSODA
SET DA=RXF
SET DIE="^PSRX("_DA(1)_",1,"
SET DR="2///"_PRKMW
DO ^DIE
SET DA=PSODA
+15 SET $PIECE(^PSRX(PSODA,3),"^")=FILLDATE
+16 ; PUT ON SUSPENSE
+17 SET (RXN,DA)=PSODA
+18 SET SD=FILLDATE
+19 IF '$GET(PSOSITE)
NEW PSOSITE
SET PSOSITE=$$RXSITE^PSOBPSUT(RXN,$GET(RXF))
+20 SET RXP=+$GET(RXPR(DA))
SET DIC="^PS(52.5,"
SET DIC(0)="L"
SET X=RXN
SET DIC("DR")=".02///"_SD_";.03////"_$PIECE(^PSRX(DA,0),"^",2)_";.04///M;.05///"_RXP_";.06////"_PSOSITE_";2///0"
KILL DD,DO
DO FILE^DICN
Begin DoDot:1
+21 KILL DD,DO
IF +Y
IF $GET(PSOEXREP)
SET $PIECE(^PS(52.5,+Y,0),"^",12)=1
+22 IF +Y
SET $PIECE(^PS(52.5,+Y,0),"^",13)=$GET(RXF)
End DoDot:1
IF +Y
IF '$GET(RXP)
IF $GET(RXRP(RXN))
SET $PIECE(^PS(52.5,+Y,0),"^",12)=1
+23 SET $PIECE(^PSRX(RXN,"STA"),"^")=5
SET LFD=$EXTRACT(SD,4,5)_"-"_$EXTRACT(SD,6,7)_"-"_$EXTRACT(SD,2,3)
+24 SET PSOARR("UPKSUSPCOMM")=$GET(RXF)_" Susp. until "_$TRANSLATE(LFD,"-","/")
+25 DO ACT^PSORXL1
+26 SET COMM=$SELECT(RXP:"Partial ",1:"")_"Rx# "_$PIECE(^PSRX(RXN,0),"^")_" Has Been Suspended Until "_LFD_"."_$SELECT($GET(RXRP(RXN))&('$GET(RXP)):" (Reprint)",1:"")
+27 DO EN^PSOHLSN1(RXN,"SC","ZS",COMM)
+28 QUIT
+29 ;
GETRELDT(DA) ; get release date of last fill
+1 NEW I,RXF
+2 SET RXF=0
FOR I=0:0
SET I=$ORDER(^PSRX(DA,1,I))
if 'I
QUIT
SET RXF=I
SET RSDT=$PIECE(^(I,0),"^",18)
+3 SET RXIEN=DA
+4 IF 'RXF
SET RSDT=$PIECE(^PSRX(DA,2),"^",13)
+5 QUIT
+6 ;
CHKLBL(PSODA,RXF) ; see if label has printed for this fill
+1 NEW LBL
+2 SET LBLP=0
+3 FOR LBL=0:0
SET LBL=$ORDER(^PSRX(PSODA,"L",LBL))
if 'LBL
QUIT
IF $PIECE(^PSRX(PSODA,"L",LBL,0),"^",2)=RXF
SET LBLP=1
+4 QUIT
+5 ;
CHKPARK(DA,RESULT) ; Entry point for AudioCARE API to determine if parked original/refill
+1 ; with no refills can be requested now (will queue original/refill when refill request is received)
+2 NEW PSOPRKRF,PSORXF
+3 SET (LBLP,RESULT)=0
+4 IF '$DATA(^PSRX(DA))
QUIT
+5 ; Not Parked
IF '$GET(^PSRX(DA,"PARK"))
QUIT
+6 ; Not Active
IF +$GET(^PSRX(DA,"STA"))'=0
QUIT
+7 SET PSOPRKRF=$ORDER(^PSRX(DA,1,""))
+8 ;Check Original Fill
IF PSOPRKRF=""
IF +$PIECE(^PSRX(DA,0),"^",9)=0
Begin DoDot:1
+9 DO GETRELDT(DA)
IF 'RSDT
DO CHKLBL(DA,0)
IF 'LBLP
Begin DoDot:2
+10 SET NEXTPOSS=$PIECE(^PSRX(DA,3),"^",2)
IF NEXTPOSS<DT
SET NEXTPOSS=DT
+11 DO ^PSOCMOPA
IF '$DATA(PSOCMOP)
SET RESULT="1^"_NEXTPOSS
End DoDot:2
End DoDot:1
+12 ;Check Last Refill
IF PSOPRKRF'=""
IF +$PIECE(^PSRX(DA,0),"^",9)>0
Begin DoDot:1
+13 SET PSORXF=$ORDER(^PSRX(DA,1,99999),-1)
+14 DO GETRELDT(DA)
IF 'RSDT
DO CHKLBL(DA,PSORXF)
IF 'LBLP
Begin DoDot:2
+15 SET NEXTPOSS=$PIECE(^PSRX(DA,3),"^",2)
IF NEXTPOSS<DT
SET NEXTPOSS=DT
+16 DO ^PSOCMOPA
IF '$DATA(PSOCMOP)
SET RESULT="1^"_NEXTPOSS
End DoDot:2
End DoDot:1
+17 KILL PSOCMOP,LBLP,RSDT,NEXTPOSS
+18 QUIT
+19 ;
+20 ;
CHKPRKORIG(DA) ;
+1 NEW PSOCMOP,LBLP,RSDT
+2 IF $ORDER(^PSRX(DA,1,0))
QUIT 0
+3 DO GETRELDT(DA)
IF $GET(RSDT)
QUIT 0
+4 DO CHKLBL(DA,0)
IF $GET(LBLP)
QUIT 0
+5 DO ^PSOCMOPA
IF $DATA(PSOCMOP)
QUIT 0
+6 QUIT 1
