- 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 Jan 18, 2025@03:34:12 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