- PSOHLD ;BIR/SAB - hold unhold functionality ; OCT 04, 2023@11:10:12
- ;;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
- ;
- ; Reference to ^DD(52 in ICR #999
- ; Reference to L, UL, PSOL, and PSOUL^PSSLOCK in ICR #2789
- ;
- UHLD ; Rx Unhold
- N REASON,RXIEN
- S PSOFROM="UNHOLD" ;*488
- I '$D(PSOPAR) D ^PSOLSET G:'$D(PSOPAR) EX
- 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
- 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=16 S VALMSG="Placed on HOLD by Provider!" K Y,STA D PSOUL^PSSLOCK(DA) D ULP S VALMBCK="" Q
- 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
- S REASON=$$GET1^DIQ(52,DA,99,"I")
- I ('$D(^XUSEC("PSORPH",DUZ))),",1,7,8,98,"'[(","_REASON_",") D K Y,STA D PSOUL^PSSLOCK(DA) D ULP Q
- . S VALMSG="The HOLD can only be removed by a pharmacist",VALMBCK=""
- D FULL^VALM1 K DIR,DTOUT,DUOUT,DIRUT D NOOR I $D(DIRUT) D ULP G EX
- I DT>$P(^PSRX(DA,2),"^",6) D D ULP G EX
- .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
- .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
- 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 RXIEN=DA
- ; - Asking for UNHOLD Comments
- N HLDCOM
- S HLDCOM=$$GET1^DIQ(52,RXIEN,99.1)_" (REASON: "_$$GET1^DIQ(52,RXIEN,99)_") on "_$$GET1^DIQ(52,RXIEN,99.2)
- W !!,"HOLD COMMENTS: " F I=1:1 Q:HLDCOM="" W ?15,$E(HLDCOM,1,65),! S HLDCOM=$E(HLDCOM,66,999)
- 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
- S OTHCOM=X
- ;
- 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,",PSOUNHLD=1
- .S RLDT=$P(^PSRX(DA(1),1,DA,0),"^",18)
- .I 'RLDT D
- ..I RSDT<DT D ;353 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
- ..S DR=".01R"
- ..D ^DIE
- ..I $D(Y) D Q ;User quit the UNHOLD 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
- ..D MWPR I $D(DIRUT) K DIRUT D Q
- ...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 DR="2////"_Y D ^DIE
- .I $E($$GET1^DIQ(52.1,RXF_","_RXIEN,2))="P" S PSOTOPK=1 ;441
- .I $$GET1^DIQ(52.1,RXF_","_RXIEN,2)["W" S BINGRTE="W",BINGCRT=1 ;*488
- .S ZD(RXIEN)=$P(^PSRX(DA(1),1,DA,0),"^")
- .K PSOUNHLD Q:$D(Y) S PSORX("FILL DATE")=$P(^PSRX(DA(1),1,DA,0),"^"),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),1:DT)
- S RLDT=$P(^PSRX(RXIEN,2),"^",13),DR="",RLDTP1=$P(RLDT,".",1)
- N MWPR S MWPR=0 I 'RXF&'RLDT S DR="22R//^S X=FDT;Q;" S MWPR=1
- I RLDT&($P(^PSRX(RXIEN,2),"^",2)="") S DR="22R//^S X=RLDTP1;Q;" S MWPR=1
- D ^DIE K FDT I $D(Y) S VALMBCK="R" D ULP G EX
- I MWPR D I $D(DIRUT) K DIRUT S VALMBCK="R" D ULP G EX
- .D MWPR Q:$D(DIRUT)
- .S DR="11////"_Y D ^DIE
- S 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 'RXF,$E($$GET1^DIQ(52,RXIEN,11))="P" S PSOTOPK=1 ;441
- I 'RXF,$$GET1^DIQ(52,RXIEN,11)["W" S BINGRTE="W",BINGCRT=1 ;*488
- ;
- ; - Saving UNHOLD COMMENTS in the Refill REMARKS field.
- I $G(OTHCOM)'="" D
- . N DA,DIE,DR S DA(1)=RXIEN,DA=RXF,DIE="^PSRX("_DA(1)_",1,",DR="3///"_$E($TR(OTHCOM,";",","),1,60) D ^DIE
- ; - Logging Rx Activity Log
- D RXACT(RXIEN,"U",,$G(OTHCOM))
- ;
- S COMM="Medication Removed from Hold by Pharmacy" D EN^PSOHLSN1(RXIEN,"OE","",COMM,PSONOOR) K COMM,PSONOOR
- 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)
- S ^PSRX(RXIEN,"H")=""
- ;D ACT^PSOHLDA
- S (NEW1,NEW11)="^^"
- S (RXF,RXFL(RXIEN))=0 F JJ=0:0 S JJ=$O(^PSRX(RXIEN,1,JJ)) Q:'JJ S (RXFL(RXIEN),RXF)=JJ
- I $G(PSXSYS) D UNHOLD^PSOCMOPA I $G(XFLAG) D ULP G EX
- I $G(RXIEN) D RELC I $G(PSOHRL) D ULP G EX
- I PSORX("FILL DATE")>DT,$P(PSOPAR,"^",6) D S^PSORXL,EX,ULP Q
- S PCOMH(RXIEN)="Medication Removed from Hold by Pharmacy"
- I $G(RXIEN) S RXRH(RXIEN)=RXIEN
- 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
- I $G(PSOTOPK) D PRK^PSOPRK(RXIEN) D ULP G EX ;441
- ;
- ; - 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,943","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(RXIEN)<220 S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_RXIEN_","
- E S PSORX("PSOL",PSOX2+1)=RXIEN_","
- ;
- D ULP
- EX 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,RFDATE,DI,DQ,%,RFN,XFLAG
- K HRX,PSHLD,PSOLIST,PSORX("FILL DATE"),STA,QTY,RFDT,PSORX0,PSRXN,RXF,JJ,PSOTOPK Q
- ;
- HLD ;
- 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 '$D(^XUSEC("PSORPH",DUZ))&'$D(^XUSEC("PSO TECH ADV",DUZ)) S VALMSG="Invalid Action Selection!",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 D NOOR I $D(DIRUT) D ULP G D1
- D HLD^PSOCMOPA I $G(XFLAG) K XFLAG D ULP G D1
- K DIR S DIR("A")=$P(^DD(52,99,0),"^"),DIR(0)="52,99"
- ; A reduced set of HOLD REASON CODEs is available for Pharmacy Techs
- I '$D(^XUSEC("PSORPH",DUZ)) D
- . S DIR(0)="S^1:INSUFFICIENT QTY IN STOCK;7:BAD ADDRESS;8:PER PATIENT REQUEST;98:OTHER/TECH (NON-CLINICAL)"
- . S DIR("L",1)="Enter reason medication is placed in a 'Hold' status."
- . S DIR("L",2)="Choose from:"
- . S DIR("L",3)="1 INSUFFICIENT QTY IN STOCK"
- . S DIR("L",4)="7 BAD ADDRESS"
- . S DIR("L",5)="8 PER PATIENT REQUEST"
- . S DIR("L")="98 OTHER/TECH (NON-CLINICAL)"
- ;
- D ^DIR S FLD(99)=Y I $D(DUOUT)!($D(DIRUT)) K DIRUT,DUOUT,DIR D ULP G D1
- 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
- E K DIR S DIR(0)="FO^10:100",DIR("A")="HOLD COMMENTS" D ^DIR S FLD(99.1)=Y
- AR I $D(DUOUT)!($D(DTOUT)) K DIRUT,DUOUT,DIR S VALMBCK="R" D ULP G D1
- 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
- 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
- ;
- H ; - Rx HOLD update
- D HOLD^PSOHLDA
- Q
- ;
- FLD N DA K DIR S DIR("A")=$P(^DD(52,99,0),"^"),DIR(0)="52,99" D
- .; A reduced set of HOLD REASON CODEs is available for Pharmacy Techs ;*370
- .I $D(^XUSEC("PSORPH",DUZ)) Q
- .S DIR(0)="S^1:INSUFFICIENT QTY IN STOCK;7:BAD ADDRESS;8:PER PATIENT REQUEST;98:OTHER/TECH (NON-CLINICAL)"
- .S DIR("L",1)="Enter reason medication is placed in a 'Hold' status."
- .S DIR("L",2)="Choose from:"
- .S DIR("L",3)="1 INSUFFICIENT QTY IN STOCK"
- .S DIR("L",4)="7 BAD ADDRESS"
- .S DIR("L",5)="8 PER PATIENT REQUEST"
- .S DIR("L")="98 OTHER/TECH (NON-CLINICAL)"
- D ^DIR Q:$D(DUOUT)!($D(DIRUT)) S FLD(99)=Y
- S COMM=Y(0)
- 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
- E S FLD(99.1)=""
- Q
- NOOR ;ask nature of order
- K DIR,DTOUT,DTOUT,DIRUT I $T(NA^ORX1)]"" D Q
- .S PSONOOR=$$NA^ORX1("W",0,"B","Nature of Order",0,"WPSDIVR"_$S(+$G(^VA(200,DUZ,"PS")):"E",1:""))
- .I +PSONOOR S PSONOOR=$P(PSONOOR,"^",3) Q
- .S DIRUT=1 K PSONOOR
- S DIR("A")="Nature of Order: ",DIR("B")="WRITTEN"
- 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:"")
- NOORX D ^DIR K DIR,DTOUT,DTOUT Q:$D(DIRUT) S PSONOOR=Y
- Q
- ULP ;
- D UL^PSSLOCK(+$G(PSODFN))
- Q
- RELC ;
- 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
- I $G(PSOHTX) S PSOHRL=$S($P($G(^PSRX(DA,1,PSOHTX,0)),"^",18):1,1:0)
- I '$G(PSOHTX) S PSOHRL=$S($P($G(^PSRX(DA,2)),"^",13):1,1:0)
- K PSOHTX,PSOHT
- Q
- RXACT(RX,ACTION,REASON,OTHCOM,SUS) ; Adds HOLD/UNHOLD comments to the Rx Activity Log
- N RFL,X,DIC,DA,DD,DO,DR,DINUM,Y,DLAYGO,COMM
- S RFL=$$LSTRFL^PSOBPSU1(RX)
- I ACTION="H" S COMM="Rx placed on HOLD (Reason: "_REASON_")"_$S(+$G(SUS):" and removed from SUSPENSE",1:"")
- I ACTION="U" S COMM="Rx removed from HOLD"
- 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///"_ACTION_";.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
- Q
- ;
- MWPR ;
- N RESULTS,PSOPARKX,DV K DIR,DUOUT,DTOUT,DIRUT
- S RESULTS="PSOPARKX" D GETPARK^PSORPC01()
- I $G(PSOPARKX(0))="YES",'$G(RXF) S DIR(0)="S^M:MAIL;W:WINDOW;P:PARK",DIR("A")="MAIL/WINDOW/PARK"
- E S DIR(0)="S^M:MAIL;W:WINDOW",DIR("A")="MAIL/WINDOW"
- S DV=$S(RXF:$$GET1^DIQ(52.1,RXF_","_RXIEN,2),1:$$GET1^DIQ(52,RXIEN,11))
- S:$E(DV)="P" DV="PARK"
- I $E(DV)="P",DIR(0)'["P:" S DV=""
- S DIR("B")=DV
- D ^DIR K DIR,DUOUT,DTOUT
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOHLD 11800 printed Feb 18, 2025@23:56:07 Page 2
- 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
- +2 ;
- +3 ; Reference to ^DD(52 in ICR #999
- +4 ; Reference to L, UL, PSOL, and PSOUL^PSSLOCK in ICR #2789
- +5 ;
- UHLD ; Rx Unhold
- +1 NEW REASON,RXIEN
- +2 ;*488
- SET PSOFROM="UNHOLD"
- +3 IF '$DATA(PSOPAR)
- DO ^PSOLSET
- if '$DATA(PSOPAR)
- GOTO EX
- +4 IF $GET(PSOBEDT)
- WRITE $CHAR(7),$CHAR(7)
- SET VALMSG="Invalid Action at this time !"
- SET VALMBCK=""
- QUIT
- +5 IF $GET(PSONACT)
- WRITE $CHAR(7),$CHAR(7)
- SET VALMSG="No Pharmacy Orderable Item !"
- SET VALMBCK=""
- QUIT
- +6 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
- +7 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
- +8 SET Y(0)=^PSRX(DA,0)
- SET STA=+$GET(^("STA"))
- +9 IF STA=16
- SET VALMSG="Placed on HOLD by Provider!"
- KILL Y,STA
- DO PSOUL^PSSLOCK(DA)
- DO ULP
- SET VALMBCK=""
- QUIT
- +10 IF STA'=3!(('$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
- +11 SET REASON=$$GET1^DIQ(52,DA,99,"I")
- +12 IF ('$DATA(^XUSEC("PSORPH",DUZ)))
- IF ",1,7,8,98,"'[(","_REASON_",")
- Begin DoDot:1
- +13 SET VALMSG="The HOLD can only be removed by a pharmacist"
- SET VALMBCK=""
- End DoDot:1
- KILL Y,STA
- DO PSOUL^PSSLOCK(DA)
- DO ULP
- QUIT
- +14 DO FULL^VALM1
- KILL DIR,DTOUT,DUOUT,DIRUT
- DO NOOR
- IF $DATA(DIRUT)
- DO ULP
- GOTO EX
- +15 IF DT>$PIECE(^PSRX(DA,2),"^",6)
- Begin DoDot:1
- +16 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)
- IF $PIECE(^PSRX(DA,"STA"),"^")<11
- SET $PIECE(^PSRX(DA,"STA"),"^")=11
- +17 SET ^PSRX(DA,"H")=""
- SET COMM="Medication Expired on "_$EXTRACT($PIECE(^(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: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 RXIEN=DA
- +2 ; - Asking for UNHOLD Comments
- +3 NEW HLDCOM
- +4 SET HLDCOM=$$GET1^DIQ(52,RXIEN,99.1)_" (REASON: "_$$GET1^DIQ(52,RXIEN,99)_") on "_$$GET1^DIQ(52,RXIEN,99.2)
- +5 WRITE !!,"HOLD COMMENTS: "
- FOR I=1:1
- if HLDCOM=""
- QUIT
- WRITE ?15,$EXTRACT(HLDCOM,1,65),!
- SET HLDCOM=$EXTRACT(HLDCOM,66,999)
- +6 KILL DIR,DUOUT,DTOUT
- SET DIR(0)="FO^3:200"
- SET DIR("A")="UNHOLD COMMENTS"
- DO ^DIR
- IF $DATA(DTOUT)!$DATA(DUOUT)
- DO ULP
- GOTO EX
- +7 SET OTHCOM=X
- +8 ;
- +9 KILL Y
- IF RXF
- Begin DoDot:1
- +10 NEW DA,DIE
- SET DA(1)=RXIEN
- SET DA=RXF
- SET DIE="^PSRX("_DA(1)_",1,"
- SET PSOUNHLD=1
- +11 SET RLDT=$PIECE(^PSRX(DA(1),1,DA,0),"^",18)
- +12 IF 'RLDT
- Begin DoDot:2
- +13 ;353 Do not display a past date for refill date'
- IF RSDT<DT
- Begin DoDot:3
- +14 NEW Y,TD
- SET Y=DT
- XECUTE ^DD("DD")
- SET TD=Y
- +15 SET DR=".01R///^S X=TD"
- +16 DO ^DIE
- End DoDot:3
- +17 SET DR=".01R"
- +18 DO ^DIE
- +19 ;User quit the UNHOLD process
- IF $DATA(Y)
- Begin DoDot:3
- +20 ;reset refill date
- IF RSDT<DT
- Begin DoDot:4
- +21 NEW Y,TD
- SET Y=RSDT
- XECUTE ^DD("DD")
- SET TD=Y
- +22 SET DR=".01R///^S X=TD"
- +23 DO ^DIE
- End DoDot:4
- End DoDot:3
- QUIT
- +24 DO MWPR
- IF $DATA(DIRUT)
- KILL DIRUT
- Begin DoDot:3
- +25 ;reset refill date
- IF RSDT<DT
- Begin DoDot:4
- +26 NEW Y,TD
- SET Y=RSDT
- XECUTE ^DD("DD")
- SET TD=Y
- +27 SET DR=".01R///^S X=TD"
- +28 DO ^DIE
- End DoDot:4
- End DoDot:3
- QUIT
- +29 SET DR="2////"_Y
- DO ^DIE
- End DoDot:2
- +30 ;441
- IF $EXTRACT($$GET1^DIQ(52.1,RXF_","_RXIEN,2))="P"
- SET PSOTOPK=1
- +31 ;*488
- IF $$GET1^DIQ(52.1,RXF_","_RXIEN,2)["W"
- SET BINGRTE="W"
- SET BINGCRT=1
- +32 SET ZD(RXIEN)=$PIECE(^PSRX(DA(1),1,DA,0),"^")
- +33 KILL PSOUNHLD
- if $DATA(Y)
- QUIT
- SET PSORX("FILL DATE")=$PIECE(^PSRX(DA(1),1,DA,0),"^")
- SET DA=PSDA
- KILL DA(1)
- End DoDot:1
- IF $DATA(Y)
- DO ULP
- GOTO EX
- +34 ;
- +35 ;PSO*7*298 Require an entry into fill date
- +36 SET ACT=1
- SET DIE="^PSRX("
- SET FDT=$SELECT($PIECE(^PSRX(RXIEN,2),"^",2):$PIECE(^PSRX(RXIEN,2),"^",2),1:DT)
- +37 SET RLDT=$PIECE(^PSRX(RXIEN,2),"^",13)
- SET DR=""
- SET RLDTP1=$PIECE(RLDT,".",1)
- +38 NEW MWPR
- SET MWPR=0
- IF 'RXF&'RLDT
- SET DR="22R//^S X=FDT;Q;"
- SET MWPR=1
- +39 IF RLDT&($PIECE(^PSRX(RXIEN,2),"^",2)="")
- SET DR="22R//^S X=RLDTP1;Q;"
- SET MWPR=1
- +40 DO ^DIE
- KILL FDT
- IF $DATA(Y)
- SET VALMBCK="R"
- DO ULP
- GOTO EX
- +41 IF MWPR
- Begin DoDot:1
- +42 DO MWPR
- if $DATA(DIRUT)
- QUIT
- +43 SET DR="11////"_Y
- DO ^DIE
- End DoDot:1
- IF $DATA(DIRUT)
- KILL DIRUT
- SET VALMBCK="R"
- DO ULP
- GOTO EX
- +44 SET DR="100///0;101///^S X=$S(RXF:$G(ZD(RXIEN)),1:$P(^PSRX(RXIEN,2),""^"",2))"
- +45 DO ^DIE
- KILL FDT
- IF $DATA(Y)
- SET VALMBCK="R"
- DO ULP
- GOTO EX
- +46 ;441
- IF 'RXF
- IF $EXTRACT($$GET1^DIQ(52,RXIEN,11))="P"
- SET PSOTOPK=1
- +47 ;*488
- IF 'RXF
- IF $$GET1^DIQ(52,RXIEN,11)["W"
- SET BINGRTE="W"
- SET BINGCRT=1
- +48 ;
- +49 ; - Saving UNHOLD COMMENTS in the Refill REMARKS field.
- +50 IF $GET(OTHCOM)'=""
- Begin DoDot:1
- +51 NEW DA,DIE,DR
- SET DA(1)=RXIEN
- SET DA=RXF
- SET DIE="^PSRX("_DA(1)_",1,"
- SET DR="3///"_$EXTRACT($TRANSLATE(OTHCOM,";",","),1,60)
- DO ^DIE
- End DoDot:1
- +52 ; - Logging Rx Activity Log
- +53 DO RXACT(RXIEN,"U",,$GET(OTHCOM))
- +54 ;
- +55 SET COMM="Medication Removed from Hold by Pharmacy"
- DO EN^PSOHLSN1(RXIEN,"OE","",COMM,PSONOOR)
- KILL COMM,PSONOOR
- +56 SET PSORX("FILL DATE")=$SELECT('RXF:$PIECE(^PSRX(RXIEN,2),"^",2),1:ZD(RXIEN))
- IF $GET(^PSRX(RXIEN,"H"))
- KILL ^PSRX("AH",$PIECE(^PSRX(RXIEN,"H"),"^"),DA)
- +57 SET ^PSRX(RXIEN,"H")=""
- +58 ;D ACT^PSOHLDA
- +59 SET (NEW1,NEW11)="^^"
- +60 SET (RXF,RXFL(RXIEN))=0
- FOR JJ=0:0
- SET JJ=$ORDER(^PSRX(RXIEN,1,JJ))
- if 'JJ
- QUIT
- SET (RXFL(RXIEN),RXF)=JJ
- +61 IF $GET(PSXSYS)
- DO UNHOLD^PSOCMOPA
- IF $GET(XFLAG)
- DO ULP
- GOTO EX
- +62 IF $GET(RXIEN)
- DO RELC
- IF $GET(PSOHRL)
- DO ULP
- GOTO EX
- +63 IF PSORX("FILL DATE")>DT
- IF $PIECE(PSOPAR,"^",6)
- DO S^PSORXL
- DO EX
- DO ULP
- QUIT
- +64 SET PCOMH(RXIEN)="Medication Removed from Hold by Pharmacy"
- +65 IF $GET(RXIEN)
- SET RXRH(RXIEN)=RXIEN
- +66 ; MARK PRESCRIPTION AND LABEL AS BEING REPRINTED WHEN UNHOLDING A RETURNED TO STOCK PRESCRIPTION
- 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)
- +67 ;441
- IF $GET(PSOTOPK)
- DO PRK^PSOPRK(RXIEN)
- DO ULP
- GOTO EX
- +68 ;
- +69 ; - Submitting Rx to ECME
- +70 NEW ACTION
- +71 IF $$SUBMIT^PSOBPSUT(RXIEN,+$GET(RXFL(RXIEN)))
- Begin DoDot:1
- +72 NEW RX,RFL
- SET RX=RXIEN
- SET RFL=+$GET(RXFL(RXIEN))
- +73 NEW DA
- SET ACTION=""
- +74 DO ECMESND^PSOBPSU1(RX,RFL,,$SELECT(RFL:"RF",1:"OF"))
- +75 ; Quit if there is an unresolved TRICARE/CHAMPVA non-billable reject code, PSO*7*358
- +76 IF $$PSOET^PSOREJP3(RX,RFL)
- SET ACTION="Q"
- QUIT
- +77 IF $$FIND^PSOREJUT(RX,RFL)
- Begin DoDot:2
- +78 SET ACTION=$$HDLG^PSOREJU1(RX,RFL,"79,88,943","ED","IOQ","Q")
- End DoDot:2
- End DoDot:1
- IF ACTION="Q"!(ACTION="^")
- DO ULP
- GOTO EX
- +79 ;
- +80 IF $GET(PSORX("PSOL",1))']""
- SET PSORX("PSOL",1)=RXIEN_","
- DO ULP
- GOTO EX
- +81 FOR PSOX1=0:0
- SET PSOX1=$ORDER(PSORX("PSOL",PSOX1))
- if 'PSOX1
- QUIT
- SET PSOX2=PSOX1
- +82 IF $LENGTH(PSORX("PSOL",PSOX2))+$LENGTH(RXIEN)<220
- SET PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_RXIEN_","
- +83 IF '$TEST
- SET PSORX("PSOL",PSOX2+1)=RXIEN_","
- +84 ;
- +85 DO ULP
- EX DO PSOUL^PSSLOCK($PIECE(PSOLST(ORN),"^",2))
- DO ^PSOBUILD
- +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,RFDATE,DI,DQ,%,RFN,XFLAG
- +2 KILL HRX,PSHLD,PSOLIST,PSORX("FILL DATE"),STA,QTY,RFDT,PSORX0,PSRXN,RXF,JJ,PSOTOPK
- QUIT
- +3 ;
- HLD ;
- +1 IF $GET(PSOBEDT)
- WRITE $CHAR(7),$CHAR(7)
- SET VALMSG="Invalid Action at this time !"
- SET VALMBCK=""
- QUIT
- +2 IF $GET(PSONACT)
- WRITE $CHAR(7),$CHAR(7)
- SET VALMSG="No Pharmacy Orderable Item !"
- SET VALMBCK=""
- QUIT
- +3 IF '$DATA(^XUSEC("PSORPH",DUZ))&'$DATA(^XUSEC("PSO TECH ADV",DUZ))
- SET VALMSG="Invalid Action Selection!"
- SET VALMBCK=""
- QUIT
- +4 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
- +5 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
- +6 SET Y(0)=^PSRX(DA,0)
- SET STA=+$GET(^("STA"))
- IF DT>$PIECE(^PSRX(DA,2),"^",6)
- Begin DoDot:1
- +7 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"
- +8 IF $PIECE(^PSRX(DA,"STA"),"^")<11
- SET $PIECE(^PSRX(DA,"STA"),"^")=11
- Begin DoDot:2
- +9 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
- +10 SET ST=$PIECE("ERROR^ACTIVE^NON-VERIFIED^REFILL^HOLD^NON-VERIFIED^SUSPENDED^^^^^DONE^EXPIRED^DISCONTINUED^DELETED^DISCONTINUED^DISCONTINUED (EDIT)^PROVIDER HOLD^","^",STA+2)
- +11 IF STA
- IF STA'>4!(STA>11)
- Begin DoDot:1
- +12 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
- +13 DO FULL^VALM1
- DO NOOR
- IF $DATA(DIRUT)
- DO ULP
- GOTO D1
- +14 DO HLD^PSOCMOPA
- IF $GET(XFLAG)
- KILL XFLAG
- DO ULP
- GOTO D1
- +15 KILL DIR
- SET DIR("A")=$PIECE(^DD(52,99,0),"^")
- SET DIR(0)="52,99"
- +16 ; A reduced set of HOLD REASON CODEs is available for Pharmacy Techs
- +17 IF '$DATA(^XUSEC("PSORPH",DUZ))
- Begin DoDot:1
- +18 SET DIR(0)="S^1:INSUFFICIENT QTY IN STOCK;7:BAD ADDRESS;8:PER PATIENT REQUEST;98:OTHER/TECH (NON-CLINICAL)"
- +19 SET DIR("L",1)="Enter reason medication is placed in a 'Hold' status."
- +20 SET DIR("L",2)="Choose from:"
- +21 SET DIR("L",3)="1 INSUFFICIENT QTY IN STOCK"
- +22 SET DIR("L",4)="7 BAD ADDRESS"
- +23 SET DIR("L",5)="8 PER PATIENT REQUEST"
- +24 SET DIR("L")="98 OTHER/TECH (NON-CLINICAL)"
- End DoDot:1
- +25 ;
- +26 DO ^DIR
- SET FLD(99)=Y
- IF $DATA(DUOUT)!($DATA(DIRUT))
- KILL DIRUT,DUOUT,DIR
- DO ULP
- GOTO D1
- +27 IF ($GET(FLD(99))=98!($GET(FLD(99))=99))
- KILL DIR
- SET DIR("A")=$PIECE(^DD(52,99.1,0),"^")
- SET DIR(0)="52,99.1"
- DO ^DIR
- SET FLD(99.1)=Y
- GOTO AR
- +28 IF '$TEST
- KILL DIR
- SET DIR(0)="FO^10:100"
- SET DIR("A")="HOLD COMMENTS"
- DO ^DIR
- SET FLD(99.1)=Y
- AR IF $DATA(DUOUT)!($DATA(DTOUT))
- KILL DIRUT,DUOUT,DIR
- SET VALMBCK="R"
- DO ULP
- GOTO D1
- +1 FOR PI=1:1
- if $PIECE(PPL,",",PI)=""
- QUIT
- SET DA=$PIECE(PPL,",",PI)
- DO H
- SET DA=PSDA
- KILL PSDA
- if $DATA(PSORX("PSOL"))
- DO RMP^PSOHLDA
- +2 KILL PI
- DO ^PSOBUILD
- +3 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 ;
- H ; - Rx HOLD update
- +1 DO HOLD^PSOHLDA
- +2 QUIT
- +3 ;
- FLD NEW DA
- KILL DIR
- SET DIR("A")=$PIECE(^DD(52,99,0),"^")
- SET DIR(0)="52,99"
- Begin DoDot:1
- +1 ; A reduced set of HOLD REASON CODEs is available for Pharmacy Techs ;*370
- +2 IF $DATA(^XUSEC("PSORPH",DUZ))
- QUIT
- +3 SET DIR(0)="S^1:INSUFFICIENT QTY IN STOCK;7:BAD ADDRESS;8:PER PATIENT REQUEST;98:OTHER/TECH (NON-CLINICAL)"
- +4 SET DIR("L",1)="Enter reason medication is placed in a 'Hold' status."
- +5 SET DIR("L",2)="Choose from:"
- +6 SET DIR("L",3)="1 INSUFFICIENT QTY IN STOCK"
- +7 SET DIR("L",4)="7 BAD ADDRESS"
- +8 SET DIR("L",5)="8 PER PATIENT REQUEST"
- +9 SET DIR("L")="98 OTHER/TECH (NON-CLINICAL)"
- End DoDot:1
- +10 DO ^DIR
- if $DATA(DUOUT)!($DATA(DIRUT))
- QUIT
- SET FLD(99)=Y
- +11 SET COMM=Y(0)
- +12 IF $GET(FLD(99))=99
- KILL DIR
- SET DIR("A")=$PIECE(^DD(52,99.1,0),"^")
- SET DIR(0)="52,99.1"
- DO ^DIR
- if $DATA(DUOUT)!($DATA(DIRUT))
- QUIT
- SET (FLD(99.1),COMM)=Y
- QUIT
- +13 IF '$TEST
- SET FLD(99.1)=""
- +14 QUIT
- NOOR ;ask nature of order
- +1 KILL DIR,DTOUT,DTOUT,DIRUT
- IF $TEXT(NA^ORX1)]""
- Begin DoDot:1
- +2 SET PSONOOR=$$NA^ORX1("W",0,"B","Nature of Order",0,"WPSDIVR"_$SELECT(+$GET(^VA(200,DUZ,"PS")):"E",1:""))
- +3 IF +PSONOOR
- SET PSONOOR=$PIECE(PSONOOR,"^",3)
- QUIT
- +4 SET DIRUT=1
- KILL PSONOOR
- End DoDot:1
- QUIT
- +5 SET DIR("A")="Nature of Order: "
- SET DIR("B")="WRITTEN"
- +6 SET DIR(0)="SA^W:WRITTEN;V:VERBAL;P:TELEPHONE;S:SERVICE CORRECTED;D:DUPLICATE;I:POLICY;R:SERVICE REJECTED"_$SELECT(+$GET(^VA(200,DUZ,"PS")):";E:PROVIDER ENTERED",1:"")
- NOORX DO ^DIR
- KILL DIR,DTOUT,DTOUT
- if $DATA(DIRUT)
- QUIT
- SET PSONOOR=Y
- +1 QUIT
- ULP ;
- +1 DO UL^PSSLOCK(+$GET(PSODFN))
- +2 QUIT
- RELC ;
- +1 SET (PSOHRL,PSOHTX)=0
- FOR PSOHT=0:0
- SET PSOHT=$ORDER(^PSRX(DA,1,PSOHT))
- if 'PSOHT
- QUIT
- if $DATA(^PSRX(DA,1,PSOHT,0))
- SET PSOHTX=PSOHT
- +2 IF $GET(PSOHTX)
- SET PSOHRL=$SELECT($PIECE($GET(^PSRX(DA,1,PSOHTX,0)),"^",18):1,1:0)
- +3 IF '$GET(PSOHTX)
- SET PSOHRL=$SELECT($PIECE($GET(^PSRX(DA,2)),"^",13):1,1:0)
- +4 KILL PSOHTX,PSOHT
- +5 QUIT
- RXACT(RX,ACTION,REASON,OTHCOM,SUS) ; Adds HOLD/UNHOLD comments to the Rx Activity Log
- +1 NEW RFL,X,DIC,DA,DD,DO,DR,DINUM,Y,DLAYGO,COMM
- +2 SET RFL=$$LSTRFL^PSOBPSU1(RX)
- +3 IF ACTION="H"
- SET COMM="Rx placed on HOLD (Reason: "_REASON_")"_$SELECT(+$GET(SUS):" and removed from SUSPENSE",1:"")
- +4 IF ACTION="U"
- SET COMM="Rx removed from HOLD"
- +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///"_ACTION_";.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 QUIT
- +9 ;
- MWPR ;
- +1 NEW RESULTS,PSOPARKX,DV
- KILL DIR,DUOUT,DTOUT,DIRUT
- +2 SET RESULTS="PSOPARKX"
- DO GETPARK^PSORPC01()
- +3 IF $GET(PSOPARKX(0))="YES"
- IF '$GET(RXF)
- SET DIR(0)="S^M:MAIL;W:WINDOW;P:PARK"
- SET DIR("A")="MAIL/WINDOW/PARK"
- +4 IF '$TEST
- SET DIR(0)="S^M:MAIL;W:WINDOW"
- SET DIR("A")="MAIL/WINDOW"
- +5 SET DV=$SELECT(RXF:$$GET1^DIQ(52.1,RXF_","_RXIEN,2),1:$$GET1^DIQ(52,RXIEN,11))
- +6 if $EXTRACT(DV)="P"
- SET DV="PARK"
- +7 IF $EXTRACT(DV)="P"
- IF DIR(0)'["P:"
- SET DV=""
- +8 SET DIR("B")=DV
- +9 DO ^DIR
- KILL DIR,DUOUT,DTOUT
- +10 QUIT