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

PSOPRK.m

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