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

PSOHLD.m

Go to the documentation of this file.
  1. PSOHLD ;BIR/SAB - hold unhold functionality ; OCT 04, 2023@11:10:12
  1. ;;7.0;OUTPATIENT PHARMACY;**1,16,21,24,27,32,55,82,114,130,166,148,268,281,298,358,353,385,386,370,488,562,441,712**;DEC 1997;Build 20
  1. ;
  1. ; Reference to ^DD(52 in ICR #999
  1. ; Reference to L, UL, PSOL, and PSOUL^PSSLOCK in ICR #2789
  1. ;
  1. UHLD ; Rx Unhold
  1. N REASON,RXIEN
  1. S PSOFROM="UNHOLD" ;*488
  1. I '$D(PSOPAR) D ^PSOLSET G:'$D(PSOPAR) EX
  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. 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=16 S VALMSG="Placed on HOLD by Provider!" K Y,STA D PSOUL^PSSLOCK(DA) D ULP S VALMBCK="" Q
  1. I STA'=3!(('$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. S REASON=$$GET1^DIQ(52,DA,99,"I")
  1. I ('$D(^XUSEC("PSORPH",DUZ))),",1,7,8,98,"'[(","_REASON_",") D K Y,STA D PSOUL^PSSLOCK(DA) D ULP Q
  1. . S VALMSG="The HOLD can only be removed by a pharmacist",VALMBCK=""
  1. D FULL^VALM1 K DIR,DTOUT,DUOUT,DIRUT D NOOR I $D(DIRUT) D ULP G EX
  1. I DT>$P(^PSRX(DA,2),"^",6) D D ULP G EX
  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) I $P(^PSRX(DA,"STA"),"^")<11 S $P(^PSRX(DA,"STA"),"^")=11
  1. .S ^PSRX(DA,"H")="",COMM="Medication Expired on "_$E($P(^(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. 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 RXIEN=DA
  1. ; - Asking for UNHOLD Comments
  1. N HLDCOM
  1. S HLDCOM=$$GET1^DIQ(52,RXIEN,99.1)_" (REASON: "_$$GET1^DIQ(52,RXIEN,99)_") on "_$$GET1^DIQ(52,RXIEN,99.2)
  1. W !!,"HOLD COMMENTS: " F I=1:1 Q:HLDCOM="" W ?15,$E(HLDCOM,1,65),! S HLDCOM=$E(HLDCOM,66,999)
  1. K DIR,DUOUT,DTOUT S DIR(0)="FO^3:200",DIR("A")="UNHOLD COMMENTS" D ^DIR I $D(DTOUT)!$D(DUOUT) D ULP G EX
  1. S OTHCOM=X
  1. ;
  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,",PSOUNHLD=1
  1. .S RLDT=$P(^PSRX(DA(1),1,DA,0),"^",18)
  1. .I 'RLDT D
  1. ..I RSDT<DT D ;353 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. ..S DR=".01R"
  1. ..D ^DIE
  1. ..I $D(Y) D Q ;User quit the UNHOLD 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. ..D MWPR I $D(DIRUT) K DIRUT D Q
  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 DR="2////"_Y D ^DIE
  1. .I $E($$GET1^DIQ(52.1,RXF_","_RXIEN,2))="P" S PSOTOPK=1 ;441
  1. .I $$GET1^DIQ(52.1,RXF_","_RXIEN,2)["W" S BINGRTE="W",BINGCRT=1 ;*488
  1. .S ZD(RXIEN)=$P(^PSRX(DA(1),1,DA,0),"^")
  1. .K PSOUNHLD Q:$D(Y) S PSORX("FILL DATE")=$P(^PSRX(DA(1),1,DA,0),"^"),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),1:DT)
  1. S RLDT=$P(^PSRX(RXIEN,2),"^",13),DR="",RLDTP1=$P(RLDT,".",1)
  1. N MWPR S MWPR=0 I 'RXF&'RLDT S DR="22R//^S X=FDT;Q;" S MWPR=1
  1. I RLDT&($P(^PSRX(RXIEN,2),"^",2)="") S DR="22R//^S X=RLDTP1;Q;" S MWPR=1
  1. D ^DIE K FDT I $D(Y) S VALMBCK="R" D ULP G EX
  1. I MWPR D I $D(DIRUT) K DIRUT S VALMBCK="R" D ULP G EX
  1. .D MWPR Q:$D(DIRUT)
  1. .S DR="11////"_Y D ^DIE
  1. S DR="100///0;101///^S X=$S(RXF:$G(ZD(RXIEN)),1:$P(^PSRX(RXIEN,2),""^"",2))"
  1. D ^DIE K FDT I $D(Y) S VALMBCK="R" D ULP G EX
  1. I 'RXF,$E($$GET1^DIQ(52,RXIEN,11))="P" S PSOTOPK=1 ;441
  1. I 'RXF,$$GET1^DIQ(52,RXIEN,11)["W" S BINGRTE="W",BINGCRT=1 ;*488
  1. ;
  1. ; - Saving UNHOLD COMMENTS in the Refill REMARKS field.
  1. I $G(OTHCOM)'="" D
  1. . N DA,DIE,DR S DA(1)=RXIEN,DA=RXF,DIE="^PSRX("_DA(1)_",1,",DR="3///"_$E($TR(OTHCOM,";",","),1,60) D ^DIE
  1. ; - Logging Rx Activity Log
  1. D RXACT(RXIEN,"U",,$G(OTHCOM))
  1. ;
  1. S COMM="Medication Removed from Hold by Pharmacy" D EN^PSOHLSN1(RXIEN,"OE","",COMM,PSONOOR) K COMM,PSONOOR
  1. S PSORX("FILL DATE")=$S('RXF:$P(^PSRX(RXIEN,2),"^",2),1:ZD(RXIEN)) I $G(^PSRX(RXIEN,"H")) K ^PSRX("AH",$P(^PSRX(RXIEN,"H"),"^"),DA)
  1. S ^PSRX(RXIEN,"H")=""
  1. ;D ACT^PSOHLDA
  1. S (NEW1,NEW11)="^^"
  1. S (RXF,RXFL(RXIEN))=0 F JJ=0:0 S JJ=$O(^PSRX(RXIEN,1,JJ)) Q:'JJ S (RXFL(RXIEN),RXF)=JJ
  1. I $G(PSXSYS) D UNHOLD^PSOCMOPA I $G(XFLAG) D ULP G EX
  1. I $G(RXIEN) D RELC I $G(PSOHRL) D ULP G EX
  1. I PSORX("FILL DATE")>DT,$P(PSOPAR,"^",6) D S^PSORXL,EX,ULP Q
  1. S PCOMH(RXIEN)="Medication Removed from Hold by Pharmacy"
  1. I $G(RXIEN) S RXRH(RXIEN)=RXIEN
  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) ; MARK PRESCRIPTION AND LABEL AS BEING REPRINTED WHEN UNHOLDING A RETURNED TO STOCK PRESCRIPTION
  1. I $G(PSOTOPK) D PRK^PSOPRK(RXIEN) D ULP G EX ;441
  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,943","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(RXIEN)<220 S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_RXIEN_","
  1. E S PSORX("PSOL",PSOX2+1)=RXIEN_","
  1. ;
  1. D ULP
  1. EX 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,RFDATE,DI,DQ,%,RFN,XFLAG
  1. K HRX,PSHLD,PSOLIST,PSORX("FILL DATE"),STA,QTY,RFDT,PSORX0,PSRXN,RXF,JJ,PSOTOPK Q
  1. ;
  1. HLD ;
  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 '$D(^XUSEC("PSORPH",DUZ))&'$D(^XUSEC("PSO TECH ADV",DUZ)) S VALMSG="Invalid Action Selection!",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 D NOOR I $D(DIRUT) D ULP G D1
  1. D HLD^PSOCMOPA I $G(XFLAG) K XFLAG D ULP G D1
  1. K DIR S DIR("A")=$P(^DD(52,99,0),"^"),DIR(0)="52,99"
  1. ; A reduced set of HOLD REASON CODEs is available for Pharmacy Techs
  1. I '$D(^XUSEC("PSORPH",DUZ)) D
  1. . S DIR(0)="S^1:INSUFFICIENT QTY IN STOCK;7:BAD ADDRESS;8:PER PATIENT REQUEST;98:OTHER/TECH (NON-CLINICAL)"
  1. . S DIR("L",1)="Enter reason medication is placed in a 'Hold' status."
  1. . S DIR("L",2)="Choose from:"
  1. . S DIR("L",3)="1 INSUFFICIENT QTY IN STOCK"
  1. . S DIR("L",4)="7 BAD ADDRESS"
  1. . S DIR("L",5)="8 PER PATIENT REQUEST"
  1. . S DIR("L")="98 OTHER/TECH (NON-CLINICAL)"
  1. ;
  1. D ^DIR S FLD(99)=Y I $D(DUOUT)!($D(DIRUT)) K DIRUT,DUOUT,DIR D ULP G D1
  1. I ($G(FLD(99))=98!($G(FLD(99))=99)) K DIR S DIR("A")=$P(^DD(52,99.1,0),"^"),DIR(0)="52,99.1" D ^DIR S FLD(99.1)=Y G AR
  1. E K DIR S DIR(0)="FO^10:100",DIR("A")="HOLD COMMENTS" D ^DIR S FLD(99.1)=Y
  1. AR I $D(DUOUT)!($D(DTOUT)) K DIRUT,DUOUT,DIR S VALMBCK="R" D ULP G D1
  1. F PI=1:1 Q:$P(PPL,",",PI)="" S DA=$P(PPL,",",PI) D H S DA=PSDA K PSDA D:$D(PSORX("PSOL")) RMP^PSOHLDA
  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. H ; - Rx HOLD update
  1. D HOLD^PSOHLDA
  1. Q
  1. ;
  1. FLD N DA K DIR S DIR("A")=$P(^DD(52,99,0),"^"),DIR(0)="52,99" D
  1. .; A reduced set of HOLD REASON CODEs is available for Pharmacy Techs ;*370
  1. .I $D(^XUSEC("PSORPH",DUZ)) Q
  1. .S DIR(0)="S^1:INSUFFICIENT QTY IN STOCK;7:BAD ADDRESS;8:PER PATIENT REQUEST;98:OTHER/TECH (NON-CLINICAL)"
  1. .S DIR("L",1)="Enter reason medication is placed in a 'Hold' status."
  1. .S DIR("L",2)="Choose from:"
  1. .S DIR("L",3)="1 INSUFFICIENT QTY IN STOCK"
  1. .S DIR("L",4)="7 BAD ADDRESS"
  1. .S DIR("L",5)="8 PER PATIENT REQUEST"
  1. .S DIR("L")="98 OTHER/TECH (NON-CLINICAL)"
  1. D ^DIR Q:$D(DUOUT)!($D(DIRUT)) S FLD(99)=Y
  1. S COMM=Y(0)
  1. I $G(FLD(99))=99 K DIR S DIR("A")=$P(^DD(52,99.1,0),"^"),DIR(0)="52,99.1" D ^DIR Q:$D(DUOUT)!($D(DIRUT)) S (FLD(99.1),COMM)=Y Q
  1. E S FLD(99.1)=""
  1. Q
  1. NOOR ;ask nature of order
  1. K DIR,DTOUT,DTOUT,DIRUT I $T(NA^ORX1)]"" D Q
  1. .S PSONOOR=$$NA^ORX1("W",0,"B","Nature of Order",0,"WPSDIVR"_$S(+$G(^VA(200,DUZ,"PS")):"E",1:""))
  1. .I +PSONOOR S PSONOOR=$P(PSONOOR,"^",3) Q
  1. .S DIRUT=1 K PSONOOR
  1. S DIR("A")="Nature of Order: ",DIR("B")="WRITTEN"
  1. S DIR(0)="SA^W:WRITTEN;V:VERBAL;P:TELEPHONE;S:SERVICE CORRECTED;D:DUPLICATE;I:POLICY;R:SERVICE REJECTED"_$S(+$G(^VA(200,DUZ,"PS")):";E:PROVIDER ENTERED",1:"")
  1. NOORX D ^DIR K DIR,DTOUT,DTOUT Q:$D(DIRUT) S PSONOOR=Y
  1. Q
  1. ULP ;
  1. D UL^PSSLOCK(+$G(PSODFN))
  1. Q
  1. RELC ;
  1. S (PSOHRL,PSOHTX)=0 F PSOHT=0:0 S PSOHT=$O(^PSRX(DA,1,PSOHT)) Q:'PSOHT S:$D(^PSRX(DA,1,PSOHT,0)) PSOHTX=PSOHT
  1. I $G(PSOHTX) S PSOHRL=$S($P($G(^PSRX(DA,1,PSOHTX,0)),"^",18):1,1:0)
  1. I '$G(PSOHTX) S PSOHRL=$S($P($G(^PSRX(DA,2)),"^",13):1,1:0)
  1. K PSOHTX,PSOHT
  1. Q
  1. RXACT(RX,ACTION,REASON,OTHCOM,SUS) ; Adds HOLD/UNHOLD comments to the Rx Activity Log
  1. N RFL,X,DIC,DA,DD,DO,DR,DINUM,Y,DLAYGO,COMM
  1. S RFL=$$LSTRFL^PSOBPSU1(RX)
  1. I ACTION="H" S COMM="Rx placed on HOLD (Reason: "_REASON_")"_$S(+$G(SUS):" and removed from SUSPENSE",1:"")
  1. I ACTION="U" S COMM="Rx removed from HOLD"
  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///"_ACTION_";.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. Q
  1. ;
  1. MWPR ;
  1. N RESULTS,PSOPARKX,DV K DIR,DUOUT,DTOUT,DIRUT
  1. S RESULTS="PSOPARKX" D GETPARK^PSORPC01()
  1. I $G(PSOPARKX(0))="YES",'$G(RXF) S DIR(0)="S^M:MAIL;W:WINDOW;P:PARK",DIR("A")="MAIL/WINDOW/PARK"
  1. E S DIR(0)="S^M:MAIL;W:WINDOW",DIR("A")="MAIL/WINDOW"
  1. S DV=$S(RXF:$$GET1^DIQ(52.1,RXF_","_RXIEN,2),1:$$GET1^DIQ(52,RXIEN,11))
  1. S:$E(DV)="P" DV="PARK"
  1. I $E(DV)="P",DIR(0)'["P:" S DV=""
  1. S DIR("B")=DV
  1. D ^DIR K DIR,DUOUT,DTOUT
  1. Q