Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSOPRKA

PSOPRKA.m

Go to the documentation of this file.
  1. PSOPRKA ;BIR/EJW - PARK/UNPARK functionality (cont.) ; Apr 24, 2023@08:17:57
  1. ;;7.0;OUTPATIENT PHARMACY;**441,712**;DEC 1997;Build 20
  1. ;
  1. ; Reference to $$L^PSSLOCK,PSOL^PSSLOCK,PSOUL^PSSLOCK,UL^PSSLOCK in ICR #2789
  1. ;(modified from hold rtn PSOHLDA)
  1. ;NOTE for PaPI - check on ECME calls like in the PSOHLD* routines (e.g. reverse
  1. ; below may need another code besides "HLD" for parking)
  1. ;
  1. PARK(PSODA) ;park function ; Called from PSOPRK and edit for Outpatient and from PSORPC01 for Park from CPRS
  1. S (DA,PSDA)=PSODA
  1. N RXF,NEXTPOSS,BPMW,PRKMW,PSOOLDFILLDT
  1. I $P($G(^PSRX(DA,"STA")),"^")'=0,$P($G(^PSRX(DA,"STA")),"^")'=5 Q ; can't park unless active
  1. 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
  1. .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),"^"))
  1. .I RFN>1,'$P(^PSRX(DA,1,I,0),"^",18) S RSDT=$P(^PSRX(DA,1,RXF-1,0),"^") Q
  1. .S:RFN>1 RSDT=$P(^PSRX(DA,1,RXF,0),"^")
  1. ; FILL DATE (FLD 22),2;13=RELEASED STATUS (FLD 100),LAST DISPENSED DT (FLD 101)
  1. S PSOOLDFILLDT=$S(RXF:$P(^PSRX(DA,1,RXF,0),U,1),1:$P(^PSRX(DA,2),U,2))
  1. S NEXTPOSS=$P(^PSRX(DA,3),"^",2)
  1. 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:"")
  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
  1. S DIE="^PSRX(",DR=$S('RXF&($$CHKPRKORIG(DA)):"22///@;",1:"")_"100///0;101///"_RSDT_";102///"_NEXTPOSS D ^DIE Q:$D(Y)
  1. S ^PSRX(DA,"PARK")=1,^PSRX("APARK",1,DA)="",$P(^PSRX(DA,"STA"),"^")=0
  1. D:$D(PSORX("PSOL")) RMP(DA)
  1. K BINGRTE ; DON'T GO TO BINGO BOARD IF PARKED
  1. S PRKMW="P"
  1. I 'RXF N DA,DIE,DR S DA=PSDA,DIE="^PSRX(",DR="11///"_PRKMW D ^DIE
  1. 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
  1. S VALMSG="RX# "_$P(^PSRX(DA,0),"^")_" placed in Active/Parked status."
  1. K RXRS(DA)
  1. ; REMOVE FROM SUSPENSE WHEN PARKED
  1. 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
  1. S:+$G(PSDA) DA=PSDA D RXACT^PSOPRK(DA,"PK",,,PSUS)
  1. N PSONOOR,COMM
  1. S COMM="Medication placed in Active/Parked status "_$E(DT,4,5)_"-"_$E(DT,6,7)_"-"_$E(DT,2,3)
  1. S PSONOOR="I" ; DEFAULT TO "POLICY" FOR PARK/UNPARK
  1. HL7 D EN^PSOHLSN1(DA,"SC","",COMM,PSONOOR)
  1. ;
  1. ; - Closes any OPEN/UNRESOLVED REJECTs and Reverses ECME Claim
  1. D REVERSE^PSOBPSU1(DA,+$G(RXF),"HLD",2)
  1. ;
  1. K PSUS,RXF,I,FDA,DIC,DIE,DR,Y,X,%,%I,%H,RSDT
  1. Q
  1. ;
  1. RMP(PSODA) ;remove Rx if found in array PSORX("PSOL")
  1. Q:'$G(PSODA)
  1. N I,J,K,PSOX2,PSOX3,PSOX9 S I=0
  1. F S I=$O(PSORX("PSOL",I)) Q:'I S PSOX2=PSORX("PSOL",I) D:PSOX2[(PSODA_",")
  1. .S PSOX9="",K=0 F J=1:1 S PSOX3=$P(PSOX2,",",J) Q:'PSOX3 D
  1. ..I PSOX3=PSODA,$P($G(^PSRX(PSODA,"STA")),"^")=0 S K=1 Q
  1. ..S PSOX9=PSOX9_$S('PSOX9:"",1:",")_PSOX3
  1. .I K S:PSOX9]"" PSORX("PSOL",I)=PSOX9_"," K:PSOX9="" PSORX("PSOL",I) D:$D(BBRX(I)) RMB(PSODA)
  1. Q
  1. RMB(PSODA) ;remove Rx if found in array BBRX()
  1. S PSOX2=BBRX(I) D:PSOX2[(PSODA_",")
  1. .S PSOX9="" F J=1:1 S PSOX3=$P(PSOX2,",",J) Q:'PSOX3 S:PSOX3'=PSODA PSOX9=PSOX9_$S('PSOX9:"",1:",")_PSOX3
  1. .S:PSOX9]"" BBRX(I)=PSOX9_"," K:PSOX9="" BBRX(I)
  1. Q
  1. ;
  1. UNPARK(PSODA,PSODFN,ERRMSG,PSOARR) ; UNPARK FROM CPRS and refill option (including AudioCARE
  1. ; Process telephone refills option)
  1. ; Called from CPRS (PSORPC01 RPC) (Marks as unparked and queues fill to
  1. ; suspense if last fill is unreleased and label has not printed. If last fill
  1. ; is released, do auto refill.)
  1. N RXIEN,PSOX,STA,PSOY,PSORXFL,PSOFILNM,PSOOLDFILLDT
  1. S (DA,PSORXFL,PSOFILNM)=PSODA
  1. 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
  1. 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
  1. 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
  1. K DIR,DTOUT,DUOUT,DIRUT
  1. EN ;
  1. N I,UNRFIL
  1. S (RXF,UNRFIL)=0 F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I S RXF=I
  1. S RSDT="",LBLP=0
  1. D GETRELDT(DA)
  1. I 'RSDT D CHKLBL(DA,RXF) ; if not released, but label has printed or sent to CMOP, order new refill if available.
  1. ; If label has not printed and latest fill is not released and not sent to CMOP, process it instead of ordering new
  1. I 'RSDT,'LBLP D ^PSOCMOPA
  1. ; Unpark whether reusing fill or not
  1. D KILLPARK^PSOPRK(DA)
  1. 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
  1. .I RXF S PSORX("FILL DATE")=$P(^PSRX(DA,1,RXF,0),"^")
  1. .I 'RXF S PSORX("FILL DATE")=$P(^PSRX(DA,3),"^",2)
  1. .I PSORX("FILL DATE")<DT S PSORX("FILL DATE")=DT
  1. .S PSOOLDFILLDT=$S(RXF:$P(^PSRX(DA,1,RXF,0),"^",1),1:$P(^PSRX(DA,2),"^",2))
  1. .D UPKSUSP
  1. .S UNRFIL=1
  1. D RXACT^PSOPRK(DA,"UPK") S PSOKPK=$G(PSOKPK)+1
  1. I '$G(UNRFIL),$S('RXF:$P(^PSRX(DA,0),"^",11),RXF:$P(^PSRX(DA,1,RXF,0),"^",2),1:"")="P" D
  1. .N I,J,BPMW S I=0,BPMW=""
  1. .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")
  1. .I BPMW]"" S:'RXF $P(^PSRX(DA,0),"^",11)=BPMW S:RXF $P(^PSRX(DA,1,RXF,0),"^",2)=BPMW
  1. S:$G(ORRFILL)&('$G(UNRFIL)) UNPARK=0
  1. S:$G(ORRFILL)&($G(UNRFIL)) UNPARK=1
  1. I $G(ORRFILL)!$G(UNRFIL) G EN0
  1. I RSDT!(LBLP)!($D(PSOCMOP)) D ; If latest fill released or label printed, generate new refill using autorefill logic
  1. .K ERRMSG
  1. .D REFRX(.PSOERR)
  1. .I $G(PSOERR(1))'="" S ERRMSG(1)="Unparked. "_PSOERR(1) ; Message back to CPRS if couldn't refill
  1. ;
  1. EN0 ;
  1. D ULP
  1. EX D PSOUL^PSSLOCK(RXIEN)
  1. 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
  1. K HRX,PSPRK,PSOLIST,STA,QTY,RFDT,PSORX0,PSRXN,RXF,JJ,PSOERR
  1. K PSOUTIL,PSOX,PSOY,RSDT,RXIEN,SITE
  1. ;
  1. Q
  1. ;
  1. ULP ;
  1. D UL^PSSLOCK(+$G(PSODFN))
  1. Q
  1. ;
  1. REFRX(REFCOM) ;
  1. I $O(^PS(52.41,"ARF",PSORXFL,0)) S REFCOM(1)="Refill request already exists." Q
  1. I '$D(^PSRX(PSORXFL,0)) S REFCOM(1)="Order was not located by Pharmacy." Q
  1. I $G(PDFN),$G(PDFN)'=$P($G(^PSRX(PSORXFL,0)),"^",2) S REFCOM(1)="Patient does not match." Q
  1. ;
  1. ; Unpark released fill -> Auto Refill, file to Prescription file #52 and put on suspense
  1. D REF^PSOATRFC(PSOFILNM,.PSOERR)
  1. I $G(PSOERR(1))'="" S REFCOM(1)=PSOERR(1)
  1. Q
  1. ;
  1. UPKSUSP ; Update routing and date fields for latest fill and put on suspense
  1. N PSOX,NEXTPOSS,FILLDATE,SD
  1. S PSOX("RX0")=^PSRX(PSODA,0)
  1. S PSOX("RX2")=$G(^PSRX(PSODA,2))
  1. S PSOX("QTY")=$P(PSOX("RX0"),"^",7),PSOX("DAYS SUPPLY")=$P(PSOX("RX0"),"^",8)
  1. S X1=PSORX("FILL DATE"),X2=PSOX("DAYS SUPPLY")-10\1 D C^%DTC S PSOX1=X
  1. S FILLDATE=PSORX("FILL DATE")
  1. S NEXTPOSS=PSOX1
  1. K X,PSOX1
  1. S PSOX("MAIL/WINDOW")="M"
  1. S DIE="^PSRX(",DR=$S('RXF:"22////"_FILLDATE_";",1:"")_"100///5;102///"_NEXTPOSS D ^DIE
  1. I RXF N DA,DIE,DR S DA(1)=PSODA,DA=RXF,DIE="^PSRX("_DA(1)_",1,",DR=".01////"_FILLDATE D ^DIE
  1. S PRKMW="M"
  1. I 'RXF N DA,DIE,DR S DA=PSODA,DIE="^PSRX(",DR="11///"_PRKMW D ^DIE
  1. 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
  1. S $P(^PSRX(PSODA,3),"^")=FILLDATE
  1. ; PUT ON SUSPENSE
  1. S (RXN,DA)=PSODA
  1. S SD=FILLDATE
  1. I '$G(PSOSITE) N PSOSITE S PSOSITE=$$RXSITE^PSOBPSUT(RXN,$G(RXF))
  1. 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
  1. .K DD,DO I +Y,$G(PSOEXREP) S $P(^PS(52.5,+Y,0),"^",12)=1
  1. .I +Y S $P(^PS(52.5,+Y,0),"^",13)=$G(RXF)
  1. S $P(^PSRX(RXN,"STA"),"^")=5,LFD=$E(SD,4,5)_"-"_$E(SD,6,7)_"-"_$E(SD,2,3)
  1. S PSOARR("UPKSUSPCOMM")=$G(RXF)_" Susp. until "_$TR(LFD,"-","/")
  1. D ACT^PSORXL1
  1. S COMM=$S(RXP:"Partial ",1:"")_"Rx# "_$P(^PSRX(RXN,0),"^")_" Has Been Suspended Until "_LFD_"."_$S($G(RXRP(RXN))&('$G(RXP)):" (Reprint)",1:"")
  1. D EN^PSOHLSN1(RXN,"SC","ZS",COMM)
  1. Q
  1. ;
  1. GETRELDT(DA) ; get release date of last fill
  1. N I,RXF
  1. S RXF=0 F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I S RXF=I,RSDT=$P(^(I,0),"^",18)
  1. S RXIEN=DA
  1. I 'RXF S RSDT=$P(^PSRX(DA,2),"^",13)
  1. Q
  1. ;
  1. CHKLBL(PSODA,RXF) ; see if label has printed for this fill
  1. N LBL
  1. S LBLP=0
  1. 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
  1. Q
  1. ;
  1. 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)
  1. N PSOPRKRF,PSORXF
  1. S (LBLP,RESULT)=0
  1. I '$D(^PSRX(DA)) Q
  1. I '$G(^PSRX(DA,"PARK")) Q ; Not Parked
  1. I +$G(^PSRX(DA,"STA"))'=0 Q ; Not Active
  1. S PSOPRKRF=$O(^PSRX(DA,1,""))
  1. I PSOPRKRF="",+$P(^PSRX(DA,0),"^",9)=0 D ;Check Original Fill
  1. .D GETRELDT(DA) I 'RSDT D CHKLBL(DA,0) I 'LBLP D
  1. ..S NEXTPOSS=$P(^PSRX(DA,3),"^",2) I NEXTPOSS<DT S NEXTPOSS=DT
  1. ..D ^PSOCMOPA I '$D(PSOCMOP) S RESULT="1^"_NEXTPOSS
  1. I PSOPRKRF'="",+$P(^PSRX(DA,0),"^",9)>0 D ;Check Last Refill
  1. .S PSORXF=$O(^PSRX(DA,1,99999),-1)
  1. .D GETRELDT(DA) I 'RSDT D CHKLBL(DA,PSORXF) I 'LBLP D
  1. ..S NEXTPOSS=$P(^PSRX(DA,3),"^",2) I NEXTPOSS<DT S NEXTPOSS=DT
  1. ..D ^PSOCMOPA I '$D(PSOCMOP) S RESULT="1^"_NEXTPOSS
  1. K PSOCMOP,LBLP,RSDT,NEXTPOSS
  1. Q
  1. ;
  1. ;
  1. CHKPRKORIG(DA) ;
  1. N PSOCMOP,LBLP,RSDT
  1. I $O(^PSRX(DA,1,0)) Q 0
  1. D GETRELDT(DA) I $G(RSDT) Q 0
  1. D CHKLBL(DA,0) I $G(LBLP) Q 0
  1. D ^PSOCMOPA I $D(PSOCMOP) Q 0
  1. Q 1