- PSOPRK ;BIR/EJW - park/unpark functionality ; May 17, 2023@18:30:42
- ;;7.0;OUTPATIENT PHARMACY;**441,712**;DEC 1997;Build 20
- ;
- ; Reference to ^DD(52 in ICR #999
- ; Reference to ^PSDRUG( in ICR #221
- ; Reference to $$L^PSSLOCK,PSOL^PSSLOCK,PSOUL^PSSLOCK,UL^PSSLOCK in ICR #2789
- ;
- UNPARK ;
- N RXIEN,PSOOLDFILLDT
- I '$D(PSOPAR) D ^PSOLSET G:'$D(PSOPAR) EX
- I $G(PSOBEDT),$G(PSOREJCT) W $C(7),$C(7) S VALMSG="Invalid Action at this time !",VALMBCK="" Q
- I $G(PSONACT) W $C(7),$C(7) S VALMSG="No Pharmacy Orderable Item !",VALMBCK="" Q
- S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY S VALMSG=$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 VALMSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),VALMBCK="" K PSOMSG D ULP Q
- S Y(0)=^PSRX(DA,0),STA=+$G(^("STA"))
- I STA!('$G(^PSRX(DA,"PARK"))) S VALMSG="Cannot unpark. Prescription is not parked.",VALMBCK="" Q
- I STA'=0!(('$D(^XUSEC("PSORPH",DUZ)))&('$D(^XUSEC("PSO TECH ADV",DUZ)))) S VALMSG="Invalid Action Selection!",VALMBCK="" K Y,STA D PSOUL^PSSLOCK(DA) D ULP Q
- D FULL^VALM1 K DIR,DTOUT,DUOUT,DIRUT
- I DT>$P(^PSRX(DA,2),"^",6) D D ULP G EX
- .S (VALMSG,COMM)="Medication Expired on "_$E($P(^PSRX(DA,2),"^",6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) I $P(^PSRX(DA,"STA"),"^")<11 S $P(^PSRX(DA,"STA"),"^")=11
- .D KILLPARK(DA) D EN^PSOHLSN1(DA,"SC","ZE",COMM,"") K COMM
- EN S RXF=0 F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I S RXF=I,RSDT=$P(^(I,0),"^")
- S PSOOLDFILLDT=$S(RXF:$P(^PSRX(DA,1,RXF,0),U,1),1:$P(^PSRX(DA,2),U,2))
- S RXIEN=DA
- K Y I RXF D I $D(Y) D ULP G EX
- .N DA,DIE S DA(1)=RXIEN,DA=RXF,DIE="^PSRX("_DA(1)_",1,",PSOUNPRK=1
- .S RLDT=$P(^PSRX(DA(1),1,DA,0),"^",18)
- .I 'RLDT D
- ..I RSDT<DT D ;Do not display a past date for refill date
- ...N Y,TD S Y=DT X ^DD("DD") S TD=Y
- ...S DR=".01R///^S X=TD"
- ...D ^DIE
- ..I $D(Y) D ;User quit the UNPARK process
- ...I RSDT<DT D ;reset refill date
- ....N Y,TD S Y=RSDT X ^DD("DD") S TD=Y
- ....S DR=".01R///^S X=TD"
- ....D ^DIE
- .S ZD(RXIEN)=$P(^PSRX(DA(1),1,DA,0),"^")
- .K PSOUNPRK Q:$D(Y) S PSORX("FILL DATE")=ZD(RXIEN),DA=PSDA K DA(1)
- ;
- ;PSO*7*298 Require an entry into fill date
- S ACT=1,DIE="^PSRX(",FDT=$S($P(^PSRX(RXIEN,2),"^",2):$P(^PSRX(RXIEN,2),"^",2),$P(^PSRX(RXIEN,3),"^",2):$P(^PSRX(RXIEN,3),"^",2),1:DT)
- I FDT<DT S FDT=DT
- S RLDT=$P(^PSRX(DA,2),"^",13),DR="",RLDTP1=$P(RLDT,".",1)
- I 'RXF&'RLDT S DR="22R//^S X=FDT;Q;"
- ; DON'T INCLUDE PROMPT FOR PARK IF UNPARKING
- I RLDT&($P(^PSRX(DA,2),"^",2)="") S DR="22R//^S X=RLDTP1;Q;"
- S DR=DR_"100///0;101///^S X=$S(RXF:$G(ZD(RXIEN)),1:$P(^PSRX(RXIEN,2),""^"",2))"
- ;
- D ^DIE K FDT I $D(Y) S VALMBCK="R" D ULP G EX
- I $G(PSOFRPK) D KILLPARK(DA) G UMSG
- N PRKMW D MW I PRKMW="" S VALMBCK="R" D ULP G EX
- D KILLPARK(DA)
- I 'RXF S $P(^PSRX(DA,0),"^",11)=PRKMW
- I RXF,$D(^PSRX(DA,1,RXF,0)) S $P(^PSRX(DA,1,RXF,0),"^",2)=PRKMW
- UMSG S VALMSG="RX# "_$P(^PSRX(DA,0),"^")_" unparked"
- D RXACT(DA,"UPK")
- N PSONOOR,COMM S PSONOOR="I" ; Default to POLICY
- S COMM="Medication Removed from Park by Pharmacy" D EN^PSOHLSN1(RXIEN,"SC","",COMM,PSONOOR) K COMM
- S PSORX("FILL DATE")=$S('RXF:$P(^PSRX(DA,2),"^",2),1:ZD(RXIEN)) D KILLPARK(DA)
- S (NEW1,NEW11)="^^"
- S (RXF,RXFL(DA))=0 F JJ=0:0 S JJ=$O(^PSRX(DA,1,JJ)) Q:'JJ S (RXFL(RXIEN),RXF)=JJ
- I $G(PSXSYS) D UNPARK^PSOCMOPA I $G(XFLAG) D ULP G EX
- I $G(RXIEN) N REFCK S REFCK=0 D REFCK I $G(REFCK) D D ULP G EX
- . I $$TITRX^PSOUTL(RXIEN)="t" S VALMSG=VALMSG_" - Cannot Refill Titration Rx" Q
- . I $O(^PS(52.41,"ARF",RXIEN,0)) S VALMSG=VALMSG_" - Refill request exists" Q
- . N X,Y,DIC,JJ
- . S X=$G(PSORX("PATIENT STATUS")) S:'X X=$P(RX0,"^",3)
- . S DIC=53,DIC(0)="QXZ" D ^DIC
- . S JJ=$$MAXNUMRF^PSOUTIL(+$G(PSODRUG("IEN")),$P(RX0,"^",8),+Y,.CLOZPAT) I 'JJ S VALMSG=VALMSG_" - Not Refillable" Q
- . K X,Y,DIC,JJ
- . N PSOREF S PSOREF("MAIL/WINDOW")=$G(PRKMW),PSOREF("IRXN")=RXIEN D ^PSOREF0 ; create a refill
- ; IF FUTURE DATE, PUT ON SUSPENSE WHEN UNPARKED
- I PSORX("FILL DATE")>DT,$P(PSOPAR,"^",6) D S^PSORXL,EX,ULP Q
- S PCOMH(RXIEN)="Medication Removed from Park by Pharmacy"
- I $G(RXIEN) S RXRH(RXIEN)=RXIEN
- ; MARK PRESCRIPTION AND LABEL AS BEING REPRINTED WHEN UNPARKING A RETURNED TO STOCK PRESCRIPTION
- I $P($G(^PSRX(RXIEN,2)),"^",15)'="" S $P(^PSRX(RXIEN,2),"^",14)=1,RXRP(RXIEN)=1,$P(RXRP(RXIEN),"^",2)=$P($G(^PSRX(RXIEN,0)),"^",18)
- ;
- ; - Submitting Rx to ECME
- N ACTION
- I $$SUBMIT^PSOBPSUT(RXIEN,+$G(RXFL(RXIEN))) D I ACTION="Q"!(ACTION="^") D ULP G EX
- . N RX,RFL S RX=RXIEN,RFL=+$G(RXFL(RXIEN))
- . N DA S ACTION=""
- . D ECMESND^PSOBPSU1(RX,RFL,,$S(RFL:"RF",1:"OF"))
- . ; Quit if there is an unresolved TRICARE/CHAMPVA non-billable reject code, PSO*7*358
- . I $$PSOET^PSOREJP3(RX,RFL) S ACTION="Q" Q
- . I $$FIND^PSOREJUT(RX,RFL) D
- .. S ACTION=$$HDLG^PSOREJU1(RX,RFL,"79,88","ED","IOQ","Q")
- ;
- I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=RXIEN_"," D ULP G EX
- F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1 S PSOX2=PSOX1
- I $L(PSORX("PSOL",PSOX2))+$L(DA)<220 S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_RXIEN_","
- E S PSORX("PSOL",PSOX2+1)=RXIEN_","
- ;
- D ULP
- EX ;
- ; If called from edit (changed to or from Park), don't unlock/kill
- I $G(PSOTOPK) K DR Q
- I $G(PSOFRPK) K DR Q
- D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) D ^PSOBUILD
- 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,PSORX("FILL DATE"),STA,QTY,RFDT,PSORX0,PSRXN,RXF,JJ Q
- ;
- PARK(DA) ;
- N PSODRUG
- S PSODRUG("DEA")=$P(^PSDRUG($P(^PSRX(DA,0),"^",6),0),"^",3)
- N RESULTS,PSOPARKX
- S RESULTS="PSOPARKX" D GETPARK^PSORPC01()
- I $G(PSOPARKX(0))'="YES" S VALMSG="Park a Prescription is turned off, Invalid Action !",VALMBCK="" Q
- I $G(PSOBEDT) W $C(7),$C(7) S VALMSG="Invalid Action at this time !",VALMBCK="" Q
- I $G(PSONACT) W $C(7),$C(7) S VALMSG="No Pharmacy Orderable Item !",VALMBCK="" Q
- I $G(PSODRUG("DEA"))["D" W $C(7),$C(7) S VALMSG="This drug is not allowed to be parked!",VALMBCK="" Q
- I $P(^PSDRUG($P(^PSRX(DA,0),"^",6),0),"^")["CLOZAPINE" W $C(7),$C(7) S VALMSG="This drug is not allowed to be parked!",VALMBCK="" Q
- I '$D(^XUSEC("PSORPH",DUZ))&'$D(^XUSEC("PSO TECH ADV",DUZ)) S VALMSG="Invalid Action Selection!",VALMBCK="" Q
- I $G(^PSRX(DA,"PARK")),+$G(^PSRX(DA,"STA"))=0 S VALMSG="Already parked!",VALMBCK="" Q
- S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY S VALMSG=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient."),VALMBCK="" K PSOPLCK Q
- K PSOPLCK D PSOL^PSSLOCK(DA) I '$G(PSOMSG) S VALMSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),VALMBCK="" K PSOMSG D ULP Q
- S Y(0)=^PSRX(DA,0),STA=+$G(^("STA")) I DT>$P(^PSRX(DA,2),"^",6) D D ULP G D1
- .S VALMSG="Medication Expired on "_$E($P(^PSRX(DA,2),"^",6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3),VALMBCK="R"
- .I $P(^PSRX(DA,"STA"),"^")<11 S $P(^PSRX(DA,"STA"),"^")=11 D
- ..S COMM="Medication Expired on "_$E($P(^PSRX(DA,2),"^",6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) D EN^PSOHLSN1(DA,"SC","ZE",COMM) K COMM
- S ST=$P("ERROR^ACTIVE^NON-VERIFIED^REFILL^HOLD^NON-VERIFIED^SUSPENDED^^^^^DONE^EXPIRED^DISCONTINUED^DELETED^DISCONTINUED^DISCONTINUED (EDIT)^PROVIDER HOLD^","^",STA+2)
- I STA,STA'>4!(STA>11) D D ULP G D1
- .S VALMSG="Rx: "_$P(Y(0),"^")_" is currently in a status of "_ST,VALMBCK="R" K ST,Y Q
- D FULL^VALM1
- S PSOFROM="PARK" D EN^PSOCMOPA K PSOFROM I $G(XFLAG) K XFLAG D ULP G D1
- AR ;
- D:$D(PSORX("PSOL")) RMP^PSOPRKA(DA)
- F PI=1:1 Q:$P(PPL,",",PI)="" S DA=$P(PPL,",",PI) D PRK(DA) S DA=PSDA K PSDA D:$D(PSORX("PSOL")) RMP^PSOPRKA(DA)
- K PI D ^PSOBUILD
- D ULP
- D1 D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) K PSOMSG,PSOPLCK,RFN,DIR,RSDT,FLD,DA,ACT,X,Y,DIRUT,DUOUT,DTOUT,DIROUT
- Q
- ;
- PRK(DA) ; - Rx Park update
- ; Recheck DEA code in case called from somewhere else
- N PSODRUG
- S PSODRUG("DEA")=$P(^PSDRUG($P(^PSRX(DA,0),"^",6),0),"^",3)
- I PSODRUG("DEA")["D" Q ; DRUG MARKED AS NOT PARKABLE
- D PARK^PSOPRKA(DA)
- Q
- ;
- ULP ;
- D UL^PSSLOCK(+$G(PSODFN))
- Q
- ;
- KILLPARK(RX) ; KILL PARK level and APARK xref
- K ^PSRX(RX,"PARK"),^PSRX("APARK",1,RX)
- Q
- ;
- RXACT(RX,ACTION,REASON,OTHCOM,SUS) ; Adds PARK/UNPARK info to the Rx Activity Log
- N RFL,X,DIC,DA,DD,DO,DR,DINUM,Y,DLAYGO,COMM,PSOFILLDT,PSOFLDNM
- S RFL=$$LSTRFL^PSOBPSU1(RX)
- I ACTION="PK" S COMM="Rx placed in Parked status"_$S(+$G(SUS):" and removed from SUSPENSE",1:"")_" ("_$E(DT,4,5)_"-"_$E(DT,6,7)_"-"_$E(DT,2,3)_")"_"("_$G(BPMW)_")"
- I ACTION="UPK" S COMM="Rx removed from Parked status ("_$E(DT,4,5)_"-"_$E(DT,6,7)_"-"_$E(DT,2,3)_")"
- S DA(1)=RX,DIC="^PSRX("_RX_",""A"",",DLAYGO=52.3,DIC(0)="L" S:$G(OTHCOM)'="" OTHCOM=$TR(OTHCOM,";",","),COMM=COMM_" -"
- S DIC("DR")=".02////E;.03////"_DUZ_";.04///"_$S((RFL>5):RFL+1,1:RFL)_";.05///"_COMM_$S($G(OTHCOM)'="":";4///"_OTHCOM,1:"")
- S X=$$NOW^XLFDT() D FILE^DICN
- ;
- I $G(PSOFRPK)!($G(PSOTOPK)) Q ;if park/unpark called from EDIT, that process should update Activity log
- S COMM=$P($G(^DD(52,11,0)),"^")_" ("_$S(ACTION="UPK":"P",1:$G(BPMW))_"),"
- S PSOFILLDT=$S(RFL:$P($G(^PSRX(RX,1,RFL,0)),U,1),1:$P($G(^PSRX(RX,2)),U,2))
- I $D(PSOOLDFILLDT),PSOFILLDT'=PSOOLDFILLDT D
- . N ZZ S ZZ=PSOOLDFILLDT S:ZZ ZZ=$E(ZZ,4,5)_"-"_$E(ZZ,6,7)_"-"_$E(ZZ,2,3)
- . S PSOFLDNM=$P($G(^DD(52,22,0)),U,1)
- . I RFL S PSOFLDNM=$P($G(^DD(52.1,.01,0)),U,1)
- . S COMM=COMM_PSOFLDNM_" ("_ZZ_")"
- S DIC("DR")=".02////E;.03////"_DUZ_";.04///"_$S((RFL>5):RFL+1,1:RFL)_";.05///"_COMM
- D FILE^DICN
- ;
- Q
- ;
- MW ; WHEN UNPARKING, DON'T PROMPT FOR PARK
- I $G(PSOFRPK) Q ; If unpark called from EDIT, already prompted for this field
- K DIR
- S PRKMW=""
- S DIR(0)="S^M:MAIL;W:WINDOW",DIR("A")="MAIL/WINDOW"
- S DIR("B")="MAIL"
- D ^DIR
- I X[U!($G(DIRUT)) K Y Q
- S PRKMW=Y
- MWX K DIR,X,Y
- Q
- ;
- MWP(PSODA,PREVMWP,REFILL) ; UNHOLD;EDIT ROUTE - CHECK TO SEE IF SHOULD ALSO PROMPT FOR PARK
- N PSODRUG,PARK,PREVMWP1
- K PSOTOPK,PSOFRPK
- I $G(PREVMWP)="" S PREVMWP="M" ; SAVE "BEFORE" PICKUP ROUTE
- S PREVMWP1=$S(PREVMWP="W":"WINDOW",PREVMWP="P":"PARK",1:"MAIL")
- S PARK=0 ; SEE WHETHER TO PROMPT FOR PARK
- ;I $P($G(PSOPAR),"^",34) S PARK=1
- N RESULTS,PSOPARKX
- S RESULTS="PSOPARKX" D GETPARK^PSORPC01()
- I $G(PSOPARKX(0))="YES" S PARK=1
- I $P(^PSDRUG($P(^PSRX(PSODA,0),"^",6),0),"^")["CLOZAPINE" S PARK=0 ;*712
- S PSODRUG("DEA")=$P(^PSDRUG($P(^PSRX(PSODA,0),"^",6),0),"^",3) I PSODRUG("DEA")["D" S PARK=0
- K DIR,DIC
- S PRKMW=""
- S DIR(0)="S^M:MAIL;W:WINDOW;P:PARK",DIR("A")="MAIL/WINDOW/PARK"
- I 'PARK S DIR(0)="S^M:MAIL;W:WINDOW",DIR("A")="MAIL/WINDOW"
- S DIR("B")=PREVMWP1
- D ^DIR
- I X[U!($G(DIRUT)) K Y Q
- S PRKMW=Y
- I PRKMW="P",PREVMWP'="P" S PSOTOPK=1 ; SET VARIABLE FOR CALLING ROUTINE TO FILE PARK LEVEL,"APARK" XREF, AND REMOVE FROM SUSPENSE AND UPDT ACT. LOG RELATED TO PARKING
- I PREVMWP="P",PRKMW'="P" S PSOFRPK=1 ; CHANGED "FROM" PARK
- K X,Y
- Q
- ;
- REFCK ;
- N RSDT,LBLP
- S (RSDT,LBLP)=0
- D GETRELDT^PSOPRKA(DA)
- I 'RSDT D CHKLBL^PSOPRKA(DA,RXF)
- I 'RSDT,'LBLP D ^PSOCMOPA
- I RSDT!(LBLP)!($D(PSOCMOP)) S REFCK=1
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOPRK 11430 printed Feb 18, 2025@23:59:29 Page 2
- PSOPRK ;BIR/EJW - park/unpark functionality ; May 17, 2023@18:30:42
- +1 ;;7.0;OUTPATIENT PHARMACY;**441,712**;DEC 1997;Build 20
- +2 ;
- +3 ; Reference to ^DD(52 in ICR #999
- +4 ; Reference to ^PSDRUG( in ICR #221
- +5 ; Reference to $$L^PSSLOCK,PSOL^PSSLOCK,PSOUL^PSSLOCK,UL^PSSLOCK in ICR #2789
- +6 ;
- UNPARK ;
- +1 NEW RXIEN,PSOOLDFILLDT
- +2 IF '$DATA(PSOPAR)
- DO ^PSOLSET
- if '$DATA(PSOPAR)
- GOTO EX
- +3 IF $GET(PSOBEDT)
- IF $GET(PSOREJCT)
- WRITE $CHAR(7),$CHAR(7)
- SET VALMSG="Invalid Action at this time !"
- SET VALMBCK=""
- QUIT
- +4 IF $GET(PSONACT)
- WRITE $CHAR(7),$CHAR(7)
- SET VALMSG="No Pharmacy Orderable Item !"
- SET VALMBCK=""
- QUIT
- +5 SET PSOPLCK=$$L^PSSLOCK(PSODFN,0)
- IF '$GET(PSOPLCK)
- DO LOCK^PSOORCPY
- SET VALMSG=$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
- +6 KILL PSOPLCK
- DO PSOL^PSSLOCK(DA)
- IF '$GET(PSOMSG)
- SET VALMSG=$SELECT($PIECE($GET(PSOMSG),"^",2)'="":$PIECE($GET(PSOMSG),"^",2),1:"Another person is editing this order.")
- SET VALMBCK=""
- KILL PSOMSG
- DO ULP
- QUIT
- +7 SET Y(0)=^PSRX(DA,0)
- SET STA=+$GET(^("STA"))
- +8 IF STA!('$GET(^PSRX(DA,"PARK")))
- SET VALMSG="Cannot unpark. Prescription is not parked."
- SET VALMBCK=""
- QUIT
- +9 IF STA'=0!(('$DATA(^XUSEC("PSORPH",DUZ)))&('$DATA(^XUSEC("PSO TECH ADV",DUZ))))
- SET VALMSG="Invalid Action Selection!"
- SET VALMBCK=""
- KILL Y,STA
- DO PSOUL^PSSLOCK(DA)
- DO ULP
- QUIT
- +10 DO FULL^VALM1
- KILL DIR,DTOUT,DUOUT,DIRUT
- +11 IF DT>$PIECE(^PSRX(DA,2),"^",6)
- Begin DoDot:1
- +12 SET (VALMSG,COMM)="Medication Expired on "_$EXTRACT($PIECE(^PSRX(DA,2),"^",6),4,5)_"-"_$EXTRACT($PIECE(^(2),"^",6),6,7)_"-"_$EXTRACT($PIECE(^(2),"^",6),2,3)
- IF $PIECE(^PSRX(DA,"STA"),"^")<11
- SET $PIECE(^PSRX(DA,"STA"),"^")=11
- +13 DO KILLPARK(DA)
- DO EN^PSOHLSN1(DA,"SC","ZE",COMM,"")
- KILL COMM
- End DoDot:1
- DO ULP
- GOTO EX
- EN 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),"^")
- +1 SET PSOOLDFILLDT=$SELECT(RXF:$PIECE(^PSRX(DA,1,RXF,0),U,1),1:$PIECE(^PSRX(DA,2),U,2))
- +2 SET RXIEN=DA
- +3 KILL Y
- IF RXF
- Begin DoDot:1
- +4 NEW DA,DIE
- SET DA(1)=RXIEN
- SET DA=RXF
- SET DIE="^PSRX("_DA(1)_",1,"
- SET PSOUNPRK=1
- +5 SET RLDT=$PIECE(^PSRX(DA(1),1,DA,0),"^",18)
- +6 IF 'RLDT
- Begin DoDot:2
- +7 ;Do not display a past date for refill date
- IF RSDT<DT
- Begin DoDot:3
- +8 NEW Y,TD
- SET Y=DT
- XECUTE ^DD("DD")
- SET TD=Y
- +9 SET DR=".01R///^S X=TD"
- +10 DO ^DIE
- End DoDot:3
- +11 ;User quit the UNPARK process
- IF $DATA(Y)
- Begin DoDot:3
- +12 ;reset refill date
- IF RSDT<DT
- Begin DoDot:4
- +13 NEW Y,TD
- SET Y=RSDT
- XECUTE ^DD("DD")
- SET TD=Y
- +14 SET DR=".01R///^S X=TD"
- +15 DO ^DIE
- End DoDot:4
- End DoDot:3
- End DoDot:2
- +16 SET ZD(RXIEN)=$PIECE(^PSRX(DA(1),1,DA,0),"^")
- +17 KILL PSOUNPRK
- if $DATA(Y)
- QUIT
- SET PSORX("FILL DATE")=ZD(RXIEN)
- SET DA=PSDA
- KILL DA(1)
- End DoDot:1
- IF $DATA(Y)
- DO ULP
- GOTO EX
- +18 ;
- +19 ;PSO*7*298 Require an entry into fill date
- +20 SET ACT=1
- SET DIE="^PSRX("
- SET FDT=$SELECT($PIECE(^PSRX(RXIEN,2),"^",2):$PIECE(^PSRX(RXIEN,2),"^",2),$PIECE(^PSRX(RXIEN,3),"^",2):$PIECE(^PSRX(RXIEN,3),"^",2),1:DT)
- +21 IF FDT<DT
- SET FDT=DT
- +22 SET RLDT=$PIECE(^PSRX(DA,2),"^",13)
- SET DR=""
- SET RLDTP1=$PIECE(RLDT,".",1)
- +23 IF 'RXF&'RLDT
- SET DR="22R//^S X=FDT;Q;"
- +24 ; DON'T INCLUDE PROMPT FOR PARK IF UNPARKING
- +25 IF RLDT&($PIECE(^PSRX(DA,2),"^",2)="")
- SET DR="22R//^S X=RLDTP1;Q;"
- +26 SET DR=DR_"100///0;101///^S X=$S(RXF:$G(ZD(RXIEN)),1:$P(^PSRX(RXIEN,2),""^"",2))"
- +27 ;
- +28 DO ^DIE
- KILL FDT
- IF $DATA(Y)
- SET VALMBCK="R"
- DO ULP
- GOTO EX
- +29 IF $GET(PSOFRPK)
- DO KILLPARK(DA)
- GOTO UMSG
- +30 NEW PRKMW
- DO MW
- IF PRKMW=""
- SET VALMBCK="R"
- DO ULP
- GOTO EX
- +31 DO KILLPARK(DA)
- +32 IF 'RXF
- SET $PIECE(^PSRX(DA,0),"^",11)=PRKMW
- +33 IF RXF
- IF $DATA(^PSRX(DA,1,RXF,0))
- SET $PIECE(^PSRX(DA,1,RXF,0),"^",2)=PRKMW
- UMSG SET VALMSG="RX# "_$PIECE(^PSRX(DA,0),"^")_" unparked"
- +1 DO RXACT(DA,"UPK")
- +2 ; Default to POLICY
- NEW PSONOOR,COMM
- SET PSONOOR="I"
- +3 SET COMM="Medication Removed from Park by Pharmacy"
- DO EN^PSOHLSN1(RXIEN,"SC","",COMM,PSONOOR)
- KILL COMM
- +4 SET PSORX("FILL DATE")=$SELECT('RXF:$PIECE(^PSRX(DA,2),"^",2),1:ZD(RXIEN))
- DO KILLPARK(DA)
- +5 SET (NEW1,NEW11)="^^"
- +6 SET (RXF,RXFL(DA))=0
- FOR JJ=0:0
- SET JJ=$ORDER(^PSRX(DA,1,JJ))
- if 'JJ
- QUIT
- SET (RXFL(RXIEN),RXF)=JJ
- +7 IF $GET(PSXSYS)
- DO UNPARK^PSOCMOPA
- IF $GET(XFLAG)
- DO ULP
- GOTO EX
- +8 IF $GET(RXIEN)
- NEW REFCK
- SET REFCK=0
- DO REFCK
- IF $GET(REFCK)
- Begin DoDot:1
- +9 IF $$TITRX^PSOUTL(RXIEN)="t"
- SET VALMSG=VALMSG_" - Cannot Refill Titration Rx"
- QUIT
- +10 IF $ORDER(^PS(52.41,"ARF",RXIEN,0))
- SET VALMSG=VALMSG_" - Refill request exists"
- QUIT
- +11 NEW X,Y,DIC,JJ
- +12 SET X=$GET(PSORX("PATIENT STATUS"))
- if 'X
- SET X=$PIECE(RX0,"^",3)
- +13 SET DIC=53
- SET DIC(0)="QXZ"
- DO ^DIC
- +14 SET JJ=$$MAXNUMRF^PSOUTIL(+$GET(PSODRUG("IEN")),$PIECE(RX0,"^",8),+Y,.CLOZPAT)
- IF 'JJ
- SET VALMSG=VALMSG_" - Not Refillable"
- QUIT
- +15 KILL X,Y,DIC,JJ
- +16 ; create a refill
- NEW PSOREF
- SET PSOREF("MAIL/WINDOW")=$GET(PRKMW)
- SET PSOREF("IRXN")=RXIEN
- DO ^PSOREF0
- End DoDot:1
- DO ULP
- GOTO EX
- +17 ; IF FUTURE DATE, PUT ON SUSPENSE WHEN UNPARKED
- +18 IF PSORX("FILL DATE")>DT
- IF $PIECE(PSOPAR,"^",6)
- DO S^PSORXL
- DO EX
- DO ULP
- QUIT
- +19 SET PCOMH(RXIEN)="Medication Removed from Park by Pharmacy"
- +20 IF $GET(RXIEN)
- SET RXRH(RXIEN)=RXIEN
- +21 ; MARK PRESCRIPTION AND LABEL AS BEING REPRINTED WHEN UNPARKING A RETURNED TO STOCK PRESCRIPTION
- +22 IF $PIECE($GET(^PSRX(RXIEN,2)),"^",15)'=""
- SET $PIECE(^PSRX(RXIEN,2),"^",14)=1
- SET RXRP(RXIEN)=1
- SET $PIECE(RXRP(RXIEN),"^",2)=$PIECE($GET(^PSRX(RXIEN,0)),"^",18)
- +23 ;
- +24 ; - Submitting Rx to ECME
- +25 NEW ACTION
- +26 IF $$SUBMIT^PSOBPSUT(RXIEN,+$GET(RXFL(RXIEN)))
- Begin DoDot:1
- +27 NEW RX,RFL
- SET RX=RXIEN
- SET RFL=+$GET(RXFL(RXIEN))
- +28 NEW DA
- SET ACTION=""
- +29 DO ECMESND^PSOBPSU1(RX,RFL,,$SELECT(RFL:"RF",1:"OF"))
- +30 ; Quit if there is an unresolved TRICARE/CHAMPVA non-billable reject code, PSO*7*358
- +31 IF $$PSOET^PSOREJP3(RX,RFL)
- SET ACTION="Q"
- QUIT
- +32 IF $$FIND^PSOREJUT(RX,RFL)
- Begin DoDot:2
- +33 SET ACTION=$$HDLG^PSOREJU1(RX,RFL,"79,88","ED","IOQ","Q")
- End DoDot:2
- End DoDot:1
- IF ACTION="Q"!(ACTION="^")
- DO ULP
- GOTO EX
- +34 ;
- +35 IF $GET(PSORX("PSOL",1))']""
- SET PSORX("PSOL",1)=RXIEN_","
- DO ULP
- GOTO EX
- +36 FOR PSOX1=0:0
- SET PSOX1=$ORDER(PSORX("PSOL",PSOX1))
- if 'PSOX1
- QUIT
- SET PSOX2=PSOX1
- +37 IF $LENGTH(PSORX("PSOL",PSOX2))+$LENGTH(DA)<220
- SET PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_RXIEN_","
- +38 IF '$TEST
- SET PSORX("PSOL",PSOX2+1)=RXIEN_","
- +39 ;
- +40 DO ULP
- EX ;
- +1 ; If called from edit (changed to or from Park), don't unlock/kill
- +2 IF $GET(PSOTOPK)
- KILL DR
- QUIT
- +3 IF $GET(PSOFRPK)
- KILL DR
- QUIT
- +4 DO PSOUL^PSSLOCK($PIECE(PSOLST(ORN),"^",2))
- DO ^PSOBUILD
- +5 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
- +6 KILL HRX,PSPRK,PSOLIST,PSORX("FILL DATE"),STA,QTY,RFDT,PSORX0,PSRXN,RXF,JJ
- QUIT
- +7 ;
- PARK(DA) ;
- +1 NEW PSODRUG
- +2 SET PSODRUG("DEA")=$PIECE(^PSDRUG($PIECE(^PSRX(DA,0),"^",6),0),"^",3)
- +3 NEW RESULTS,PSOPARKX
- +4 SET RESULTS="PSOPARKX"
- DO GETPARK^PSORPC01()
- +5 IF $GET(PSOPARKX(0))'="YES"
- SET VALMSG="Park a Prescription is turned off, Invalid Action !"
- SET VALMBCK=""
- QUIT
- +6 IF $GET(PSOBEDT)
- WRITE $CHAR(7),$CHAR(7)
- SET VALMSG="Invalid Action at this time !"
- SET VALMBCK=""
- QUIT
- +7 IF $GET(PSONACT)
- WRITE $CHAR(7),$CHAR(7)
- SET VALMSG="No Pharmacy Orderable Item !"
- SET VALMBCK=""
- QUIT
- +8 IF $GET(PSODRUG("DEA"))["D"
- WRITE $CHAR(7),$CHAR(7)
- SET VALMSG="This drug is not allowed to be parked!"
- SET VALMBCK=""
- QUIT
- +9 IF $PIECE(^PSDRUG($PIECE(^PSRX(DA,0),"^",6),0),"^")["CLOZAPINE"
- WRITE $CHAR(7),$CHAR(7)
- SET VALMSG="This drug is not allowed to be parked!"
- SET VALMBCK=""
- QUIT
- +10 IF '$DATA(^XUSEC("PSORPH",DUZ))&'$DATA(^XUSEC("PSO TECH ADV",DUZ))
- SET VALMSG="Invalid Action Selection!"
- SET VALMBCK=""
- QUIT
- +11 IF $GET(^PSRX(DA,"PARK"))
- IF +$GET(^PSRX(DA,"STA"))=0
- SET VALMSG="Already parked!"
- SET VALMBCK=""
- QUIT
- +12 SET PSOPLCK=$$L^PSSLOCK(PSODFN,0)
- IF '$GET(PSOPLCK)
- DO LOCK^PSOORCPY
- SET VALMSG=$SELECT($PIECE($GET(PSOPLCK),"^",2)'="":$PIECE($GET(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.")
- SET VALMBCK=""
- KILL PSOPLCK
- QUIT
- +13 KILL PSOPLCK
- DO PSOL^PSSLOCK(DA)
- IF '$GET(PSOMSG)
- SET VALMSG=$SELECT($PIECE($GET(PSOMSG),"^",2)'="":$PIECE($GET(PSOMSG),"^",2),1:"Another person is editing this order.")
- SET VALMBCK=""
- KILL PSOMSG
- DO ULP
- QUIT
- +14 SET Y(0)=^PSRX(DA,0)
- SET STA=+$GET(^("STA"))
- IF DT>$PIECE(^PSRX(DA,2),"^",6)
- Begin DoDot:1
- +15 SET VALMSG="Medication Expired on "_$EXTRACT($PIECE(^PSRX(DA,2),"^",6),4,5)_"-"_$EXTRACT($PIECE(^(2),"^",6),6,7)_"-"_$EXTRACT($PIECE(^(2),"^",6),2,3)
- SET VALMBCK="R"
- +16 IF $PIECE(^PSRX(DA,"STA"),"^")<11
- SET $PIECE(^PSRX(DA,"STA"),"^")=11
- Begin DoDot:2
- +17 SET COMM="Medication Expired on "_$EXTRACT($PIECE(^PSRX(DA,2),"^",6),4,5)_"-"_$EXTRACT($PIECE(^(2),"^",6),6,7)_"-"_$EXTRACT($PIECE(^(2),"^",6),2,3)
- DO EN^PSOHLSN1(DA,"SC","ZE",COMM)
- KILL COMM
- End DoDot:2
- End DoDot:1
- DO ULP
- GOTO D1
- +18 SET ST=$PIECE("ERROR^ACTIVE^NON-VERIFIED^REFILL^HOLD^NON-VERIFIED^SUSPENDED^^^^^DONE^EXPIRED^DISCONTINUED^DELETED^DISCONTINUED^DISCONTINUED (EDIT)^PROVIDER HOLD^","^",STA+2)
- +19 IF STA
- IF STA'>4!(STA>11)
- Begin DoDot:1
- +20 SET VALMSG="Rx: "_$PIECE(Y(0),"^")_" is currently in a status of "_ST
- SET VALMBCK="R"
- KILL ST,Y
- QUIT
- End DoDot:1
- DO ULP
- GOTO D1
- +21 DO FULL^VALM1
- +22 SET PSOFROM="PARK"
- DO EN^PSOCMOPA
- KILL PSOFROM
- IF $GET(XFLAG)
- KILL XFLAG
- DO ULP
- GOTO D1
- AR ;
- +1 if $DATA(PSORX("PSOL"))
- DO RMP^PSOPRKA(DA)
- +2 FOR PI=1:1
- if $PIECE(PPL,",",PI)=""
- QUIT
- SET DA=$PIECE(PPL,",",PI)
- DO PRK(DA)
- SET DA=PSDA
- KILL PSDA
- if $DATA(PSORX("PSOL"))
- DO RMP^PSOPRKA(DA)
- +3 KILL PI
- DO ^PSOBUILD
- +4 DO ULP
- D1 DO PSOUL^PSSLOCK($PIECE(PSOLST(ORN),"^",2))
- KILL PSOMSG,PSOPLCK,RFN,DIR,RSDT,FLD,DA,ACT,X,Y,DIRUT,DUOUT,DTOUT,DIROUT
- +1 QUIT
- +2 ;
- PRK(DA) ; - Rx Park update
- +1 ; Recheck DEA code in case called from somewhere else
- +2 NEW PSODRUG
- +3 SET PSODRUG("DEA")=$PIECE(^PSDRUG($PIECE(^PSRX(DA,0),"^",6),0),"^",3)
- +4 ; DRUG MARKED AS NOT PARKABLE
- IF PSODRUG("DEA")["D"
- QUIT
- +5 DO PARK^PSOPRKA(DA)
- +6 QUIT
- +7 ;
- ULP ;
- +1 DO UL^PSSLOCK(+$GET(PSODFN))
- +2 QUIT
- +3 ;
- KILLPARK(RX) ; KILL PARK level and APARK xref
- +1 KILL ^PSRX(RX,"PARK"),^PSRX("APARK",1,RX)
- +2 QUIT
- +3 ;
- RXACT(RX,ACTION,REASON,OTHCOM,SUS) ; Adds PARK/UNPARK info to the Rx Activity Log
- +1 NEW RFL,X,DIC,DA,DD,DO,DR,DINUM,Y,DLAYGO,COMM,PSOFILLDT,PSOFLDNM
- +2 SET RFL=$$LSTRFL^PSOBPSU1(RX)
- +3 IF ACTION="PK"
- SET COMM="Rx placed in Parked status"_$SELECT(+$GET(SUS):" and removed from SUSPENSE",1:"")_" ("_$EXTRACT(DT,4,5)_"-"_$EXTRACT(DT,6,7)_"-"_$EXTRACT(DT,2,3)_")"_"("_$GET(BPMW)_")"
- +4 IF ACTION="UPK"
- SET COMM="Rx removed from Parked status ("_$EXTRACT(DT,4,5)_"-"_$EXTRACT(DT,6,7)_"-"_$EXTRACT(DT,2,3)_")"
- +5 SET DA(1)=RX
- SET DIC="^PSRX("_RX_",""A"","
- SET DLAYGO=52.3
- SET DIC(0)="L"
- if $GET(OTHCOM)'=""
- SET OTHCOM=$TRANSLATE(OTHCOM,";",",")
- SET COMM=COMM_" -"
- +6 SET DIC("DR")=".02////E;.03////"_DUZ_";.04///"_$SELECT((RFL>5):RFL+1,1:RFL)_";.05///"_COMM_$SELECT($GET(OTHCOM)'="":";4///"_OTHCOM,1:"")
- +7 SET X=$$NOW^XLFDT()
- DO FILE^DICN
- +8 ;
- +9 ;if park/unpark called from EDIT, that process should update Activity log
- IF $GET(PSOFRPK)!($GET(PSOTOPK))
- QUIT
- +10 SET COMM=$PIECE($GET(^DD(52,11,0)),"^")_" ("_$SELECT(ACTION="UPK":"P",1:$GET(BPMW))_"),"
- +11 SET PSOFILLDT=$SELECT(RFL:$PIECE($GET(^PSRX(RX,1,RFL,0)),U,1),1:$PIECE($GET(^PSRX(RX,2)),U,2))
- +12 IF $DATA(PSOOLDFILLDT)
- IF PSOFILLDT'=PSOOLDFILLDT
- Begin DoDot:1
- +13 NEW ZZ
- SET ZZ=PSOOLDFILLDT
- if ZZ
- SET ZZ=$EXTRACT(ZZ,4,5)_"-"_$EXTRACT(ZZ,6,7)_"-"_$EXTRACT(ZZ,2,3)
- +14 SET PSOFLDNM=$PIECE($GET(^DD(52,22,0)),U,1)
- +15 IF RFL
- SET PSOFLDNM=$PIECE($GET(^DD(52.1,.01,0)),U,1)
- +16 SET COMM=COMM_PSOFLDNM_" ("_ZZ_")"
- End DoDot:1
- +17 SET DIC("DR")=".02////E;.03////"_DUZ_";.04///"_$SELECT((RFL>5):RFL+1,1:RFL)_";.05///"_COMM
- +18 DO FILE^DICN
- +19 ;
- +20 QUIT
- +21 ;
- MW ; WHEN UNPARKING, DON'T PROMPT FOR PARK
- +1 ; If unpark called from EDIT, already prompted for this field
- IF $GET(PSOFRPK)
- QUIT
- +2 KILL DIR
- +3 SET PRKMW=""
- +4 SET DIR(0)="S^M:MAIL;W:WINDOW"
- SET DIR("A")="MAIL/WINDOW"
- +5 SET DIR("B")="MAIL"
- +6 DO ^DIR
- +7 IF X[U!($GET(DIRUT))
- KILL Y
- QUIT
- +8 SET PRKMW=Y
- MWX KILL DIR,X,Y
- +1 QUIT
- +2 ;
- MWP(PSODA,PREVMWP,REFILL) ; UNHOLD;EDIT ROUTE - CHECK TO SEE IF SHOULD ALSO PROMPT FOR PARK
- +1 NEW PSODRUG,PARK,PREVMWP1
- +2 KILL PSOTOPK,PSOFRPK
- +3 ; SAVE "BEFORE" PICKUP ROUTE
- IF $GET(PREVMWP)=""
- SET PREVMWP="M"
- +4 SET PREVMWP1=$SELECT(PREVMWP="W":"WINDOW",PREVMWP="P":"PARK",1:"MAIL")
- +5 ; SEE WHETHER TO PROMPT FOR PARK
- SET PARK=0
- +6 ;I $P($G(PSOPAR),"^",34) S PARK=1
- +7 NEW RESULTS,PSOPARKX
- +8 SET RESULTS="PSOPARKX"
- DO GETPARK^PSORPC01()
- +9 IF $GET(PSOPARKX(0))="YES"
- SET PARK=1
- +10 ;*712
- IF $PIECE(^PSDRUG($PIECE(^PSRX(PSODA,0),"^",6),0),"^")["CLOZAPINE"
- SET PARK=0
- +11 SET PSODRUG("DEA")=$PIECE(^PSDRUG($PIECE(^PSRX(PSODA,0),"^",6),0),"^",3)
- IF PSODRUG("DEA")["D"
- SET PARK=0
- +12 KILL DIR,DIC
- +13 SET PRKMW=""
- +14 SET DIR(0)="S^M:MAIL;W:WINDOW;P:PARK"
- SET DIR("A")="MAIL/WINDOW/PARK"
- +15 IF 'PARK
- SET DIR(0)="S^M:MAIL;W:WINDOW"
- SET DIR("A")="MAIL/WINDOW"
- +16 SET DIR("B")=PREVMWP1
- +17 DO ^DIR
- +18 IF X[U!($GET(DIRUT))
- KILL Y
- QUIT
- +19 SET PRKMW=Y
- +20 ; SET VARIABLE FOR CALLING ROUTINE TO FILE PARK LEVEL,"APARK" XREF, AND REMOVE FROM SUSPENSE AND UPDT ACT. LOG RELATED TO PARKING
- IF PRKMW="P"
- IF PREVMWP'="P"
- SET PSOTOPK=1
- +21 ; CHANGED "FROM" PARK
- IF PREVMWP="P"
- IF PRKMW'="P"
- SET PSOFRPK=1
- +22 KILL X,Y
- +23 QUIT
- +24 ;
- REFCK ;
- +1 NEW RSDT,LBLP
- +2 SET (RSDT,LBLP)=0
- +3 DO GETRELDT^PSOPRKA(DA)
- +4 IF 'RSDT
- DO CHKLBL^PSOPRKA(DA,RXF)
- +5 IF 'RSDT
- IF 'LBLP
- DO ^PSOCMOPA
- +6 IF RSDT!(LBLP)!($DATA(PSOCMOP))
- SET REFCK=1
- +7 QUIT
- +8 ;