PSOUTL ;BHAM ISC/SAB - PSO utility routine ;Jun 22, 2018@08:18
;;7.0;OUTPATIENT PHARMACY;**1,21,126,174,218,259,324,390,313,411,466,477,626,639,692**;DEC 1997;Build 4
;External reference to $$SERV^IBARX1 supported by DBIA 2245
;External reference to ^PS(55 supported by DBIA 2228
;External reference to ^PSSDIUTL supported by DBIA 5737
;External reference to ^DD("DD" supported by DBIA 999
;External reference to ^PS(50.7 supported by DBIA 2223
;External reference to ^PSSDSAPM supported by DBIA 5570
;
;*218 prevent refill from being deleted if pending processing via
; external dispense machines
;*259 reverse *218 restrictions & Add del only last refill logic.
;
SUSPCAN ;dcl rx from suspense used in new, renew AND verification of Rxs
S PSLAST=0 F PSI=0:0 S PSI=$O(^PSRX(PSRX,1,PSI)) Q:'PSI S PSLAST=PSI
I PSLAST S PSI=^PSRX(PSRX,1,PSLAST,0) K ^PSRX(PSRX,1,PSLAST),^PSRX(PSRX,1,"B",+PSI,PSLAST) S ^(0)=$P(^PSRX(PSRX,1,0),"^",1,3)_"^"_($P(^(0),"^",4)-1) K PSLAST,PSI,SUSX,SUS1,SUS2 Q
S $P(^PSRX(PSRX,3),"^",7)="DISCONTINUED FROM SUSPENSE BEFORE FILLING" K PSI,SUSX,SUS1,SUS2 Q
;
ACTLOG ;
N PSS
F PSI=0:0 S PSI=$O(^PSRX(PSRX,"A",PSI)) I 'PSI!'$O(^(PSI)) S ^PSRX(PSRX,"A",+PSI+1,0)=DT_"^"_PSREA_"^"_PSOCLC_"^"_PSRXREF_"^"_PSMSG,^PSRX(PSRX,"A",0)="^52.3DA^"_(+PSI+1)_"^"_(+PSI+1) Q
ACTOUT I PSREA="C" S PSI=$S($D(^PSRX(PSRX,2)):+$P(^(2),"^",6),1:0) K:$D(^PS(55,PSDFN,"P","A",PSI,PSRX)) ^(PSRX) S ^PS(55,PSDFN,"P","A",DT,PSRX)="" Q
I PSREA="R" F PSI=0:0 S PSI=$O(^PSRX(PSRX,"A",PSI)) Q:'PSI I $D(^(PSI,0)),$P(^(0),"^",2)="C" S PSS=+^(0)
I $D(PSS),PSS K:$D(^PS(55,PSDFN,"P","A",PSS,PSRX)) ^(PSRX)
I PSREA="R",$D(^PSRX(PSRX,2))#2 S ^PS(55,PSDFN,"P","A",+$P(^PSRX(PSRX,2),"^",6),PSRX)=""
Q
;
QUES ;INSTRUCTIONS FOR RENEW AND REFILL
W !?5,"Enter the item #(s) or RX #(s) you wish to ",$S(PSFROM="N":"renew ",PSFROM="R":"REFILL "),"separated by commas."
W !?5,"For example: 1,2,5 or 123456,33254A,232323B."
W !?5,"Do not enter the same number twice, duplicates are not allowed."
Q
ENDVCHK N ANS,PSPOP S PSPOP=0 Q:'PSODIV Q:'$P(^PSRX(PSRX,2),"^",9)!($P(^(2),"^",9)=PSOSITE)
CHK1 I '$P(PSOSYS,"^",2) W !?10,$C(7),"RX# ",$P(^PSRX(PSRX,0),"^")," is not a valid choice. (Different Division)" S PSPOP=1 Q
I $P(PSOSYS,"^",3) W !?10,$C(7),"RX# ",$P(^PSRX(PSRX,0),"^")," is from another division. Continue? (Y/N) " R ANS:DTIME I ANS="^"!(ANS="") S PSPOP=1 Q
I (ANS']"")!("YNyn"'[$E(ANS)) W !?10,$C(7),"Answer 'YES' or 'NO'." G CHK1
S:$E(ANS)["Nn" PSPOP=1 Q
;PSO*7*259; SET VAR PSOSFN TO CHECK FOR SUSPENDED REFILL
K52 K PSOSFN S SFN=+$O(^PS(52.5,"B",DA(1),0)),PSOSFN=SFN Q:SFN=0
I $P($G(^PS(52.5,SFN,0)),"^",5)=$P($G(^PSRX(+^PS(52.5,SFN,0),"P",0)),"^",3),$P($G(^PSRX($P(^PS(52.5,SFN,0),"^"),"P",0)),"^",4)=0 N PSOXX S PSOXX=1 G KILL
G:X'=""&($G(Y)=1) KILL I $G(Y)'=1,SFN I $D(^PS(52.5,SFN,0)),'$P(^(0),"^",5),'$P($G(^("P")),"^") D
.S SDT=+$P(^PS(52.5,SFN,0),"^",2) K ^PS(52.5,"C",SDT,SFN)
.I $P($G(^PS(52.5,SFN,0)),"^",7)="Q" K ^PS(52.5,"AQ",SDT,+$P(^PS(52.5,SFN,0),"^",3),SFN) D KCMPX^PSOCMOP(SFN,"Q")
.I $P($G(^PS(52.5,SFN,0)),"^",7)="" K ^PS(52.5,"AC",+$P(^PS(52.5,SFN,0),"^",3),SDT,SFN)
.K SFN,SDT
Q
S52 S (RIFN,PSOSX)=0 F S RIFN=$O(^PSRX(DA(1),1,RIFN)) Q:'RIFN S RFID=$P(^PSRX(DA(1),1,RIFN,0),"^"),PSOSX=PSOSX+1
S SFN=+$O(^PS(52.5,"B",DA(1),0)) I SFN,'$G(^PS(52.5,SFN,"P")),$P($G(^PSRX($P($G(^PS(52.5,SFN,0)),"^"),"STA")),"^")=5 D
.I '$D(^PS(52.5,SFN,0))!($P($G(^(0)),"^",5)) Q
.S $P(^PS(52.5,SFN,0),"^",2)=RFID,^PS(52.5,"C",RFID,SFN)=""
.I $P($G(^PS(52.5,SFN,0)),"^",7)="Q" S ^PS(52.5,"AQ",RFID,+$P(^PS(52.5,SFN,0),"^",3),SFN)="" D SCMPX^PSOCMOP(SFN,"Q")
.I $P($G(^PS(52.5,SFN,0)),"^",7)="" S ^PS(52.5,"AC",+$P(^PS(52.5,SFN,0),"^",3),RFID,SFN)=""
K SFN,RIFN,RFID,PSOSX,PSOSXDT Q
KILL N DFN
I SFN D
.S $P(^PSRX(DA(1),"STA"),"^")=0 Q:'$D(^PS(52.5,SFN,0)) S DFN=+$P(^PS(52.5,SFN,0),"^",3),PAT=$P(^DPT(DFN,0),"^")
.;I $P(^PS(52.5,SFN,0),"^",5) Q
.K ^PS(52.5,"B",+$P(^PS(52.5,SFN,0),"^"),SFN),^PS(52.5,"C",+$P(^PS(52.5,SFN,0),"^",2),SFN),^PS(52.5,"D",PAT,SFN),^PS(52.5,"AF",DFN,SFN)
.I $P($G(^PS(52.5,SFN,0)),"^",7)="" D
..I $G(^PS(52.5,SFN,"P")) K ^PS(52.5,"AS",+$P(^(0),"^",8),+$P(^(0),"^",9),+$P(^(0),"^",6),+$P(^(0),"^",11),SFN),^PS(52.5,"ADL",$E(+$P(^PS(52.5,SFN,0),"^",8),1,7),SFN) Q
..K ^PS(52.5,"AC",DFN,+$P(^PS(52.5,SFN,0),"^",2),SFN)
.I $P($G(^PS(52.5,SFN,0)),"^",7)'="" D
..;Kill CMOP xrefs
..N PSOC7 S PSOC7=$P($G(^PS(52.5,SFN,0)),"^",7)
..I PSOC7="Q"!(PSOC7="P") K ^PS(52.5,"AG",+$P(^PS(52.5,SFN,0),"^",3),SFN) D KCMPX^PSOCMOP(SFN,PSOC7)
..I PSOC7="X"!(PSOC7="P")!(PSOC7="L") K ^PS(52.5,$S(PSOC7="X":"AX",PSOC7="P":"AP",1:"AL"),$P(^PS(52.5,SFN,0),"^",2),$P(^(0),"^",3),SFN) D KCMPX^PSOCMOP(SFN,PSOC7)
..K ^PS(52.5,"APR",+$P(^PS(52.5,SFN,0),"^",8),+$P(^(0),"^",9),+$P(^(0),"^",6),+$P(^(0),"^",11),SFN),^PS(52.5,"ADL",$E(+$P(^PS(52.5,SFN,0),"^",8),1,7),SFN)
.K ^PS(52.5,SFN,0),^PS(52.5,SFN,"P"),DFN,SFN,PAT
S CNT=0 F SUB=0:0 S SUB=$O(^PSRX(DA(1),"A",SUB)) Q:'SUB S CNT=SUB
S:DA>5 DA=DA+1 D NOW^%DTC S CNT=CNT+1
S ^PSRX(DA(1),"A",0)="^52.3DA^"_CNT_"^"_CNT,^PSRX(DA(1),"A",CNT,0)=%_"^D^"_DUZ_"^"_DA_"^"
I '$D(PSOXX) S ^PSRX(DA(1),"A",CNT,0)=^PSRX(DA(1),"A",CNT,0)_"Refill "
;if PSOXX not exist, = refill. otherwise, it is a partial.
S ^PSRX(DA(1),"A",CNT,0)=^PSRX(DA(1),"A",CNT,0)_$S($G(RESK):"returned to stock.",$G(PSOPSDAL):"deleted during Controlled Subs release.",$G(PSOXX)=1:"Partial deleted from suspense file.",1:"deleted during Rx edit.") K CNT,SUB
Q
CID ;calculates six months limit on issue dates
S PSID=X,X=$S($$CSID():"T-6M",1:"T-12M"),%DT="X" D ^%DT S %DT(0)=Y,X=PSID,%DT="EX" D ^%DT K PSID
Q
CIDH S X=$S($$CSID():"T-6M",1:"T-12M"),%DT="X" D ^%DT X ^DD("DD") D EN^DDIOL("Issue Date must be greater or equal to "_Y,"","!")
Q
SPR F RF=0:0 S RF=$O(^PSRX(DA(1),1,RF)) Q:'RF S NODE=RF
I NODE=1 S $P(^PSRX(DA(1),3),"^",4)=$P(^PSRX(DA(1),2),"^",2) Q
SREF I $G(NODE) S NODE=NODE-1 G:'$D(^PSRX(DA(1),1,NODE,0)) SREF
I NODE=0 S $P(^PSRX(DA(1),3),"^",4)=$P(^PSRX(DA(1),2),"^",2) Q
S $P(^PSRX(DA(1),3),"^",4)=$P(^PSRX(DA(1),1,NODE,0),"^",1) Q
K NODE,RF
Q
KPR F RF=0:0 S RF=$O(^PSRX(DA(1),1,RF)) Q:'RF S NODE=RF
I NODE=DA&(X'="") S NODE=NODE-1 S:NODE=1 NODE=0 G:'NODE ORIG G:NODE>1 KREF
I NODE=1 S $P(^PSRX(DA(1),3),"^",4)=$P(^PSRX(DA(1),2),"^",2) G EX
KREF S NODE=NODE-1 G:'NODE EX
I NODE=1 S $P(^PSRX(DA(1),3),"^",4)=$P(^PSRX(DA(1),2),"^",2) G EX
G:NODE=DA&(X'="") KREF G:'$D(^PSRX(DA(1),1,NODE,0)) KREF
ORIG I 'NODE S $P(^PSRX(DA(1),3),"^",4)=$P(^PSRX(DA(1),2),"^",2) G EX
S $P(^PSRX(DA(1),3),"^",4)=$P(^PSRX(DA(1),1,NODE,0),"^",1) G EX
EX K NODE,RF
Q
IBSS N PSOHLP S PSOHLP(1,"F")="!!"
S PSOHLP(1)="Entry in this field must match the SERVICE field for pharmacy action"
S PSOHLP(2,"F")="!"
S PSOHLP(2)="types in the IB ACTION TYPE file AND be a valid entry in your"
S PSOHLP(3,"F")="!"
S PSOHLP(3)="SERVICE/SECTION file to generate copay charges!"
S PSOHLP(4,"F")="!!"
D EN^DDIOL(.PSOHLP) K PSOHLP
Q
IBSSR N PSOIBFL,PSOIBLP,PSOIBST S PSOIBFL=0
F PSOIBLP=0:0 S PSOIBLP=$O(^DIC(49,PSOIBLP)) Q:'PSOIBLP!(PSOIBFL) S Y=PSOIBLP,PSOIBST=$$SERV^IBARX1(+Y) I $G(PSOIBST) S DIE="^PS(59,",DA=PSOSITE,DR="1003////"_PSOIBLP D ^DIE K DIE D S PSOIBFL=1
.W $C(7),!!,"There was an invalid entry in your IB SERVICE/SECTION field in your Outpatient",!,"Site Parameter file, but we have fixed the problem for you, and you",!,"may continue!" Q
Q
WARN ;
I $G(PSOUNHLD) D Q
.D EN^DDIOL("You cannot delete a refill while removing from Hold! Use the Edit Action.","","$C(7),!!"),EN^DDIOL(" ","","!!")
I $G(CMOP(DA))]""&(+$G(CMOP(DA))<3) D K CMOP Q
.D EN^DDIOL("You cannot delete a refill that"_$S(+$G(CMOP(DA))=1:" has been released by",1:" is being transmitted to")_" the CMOP","","!!")
.D EN^DDIOL(" ","","!!")
K CMOP
;
N PSOL,PSR
S PSR=0 F S PSR=$O(^PSRX(DA(1),1,PSR)) Q:'PSR S PSOL=PSR
I DA=PSOL,$P(^PSRX(DA(1),1,DA,0),"^",18) D Q
.D EN^DDIOL("Refill Released! Use the 'Return to Stock' option!","","$C(7),!!"),EN^DDIOL(" ","","!")
;
;Only allow deletion if last refill *259
I $O(^PSRX(DA(1),1,DA)) D Q
.D EN^DDIOL("Only the last refill can be deleted. Later refills must be deleted first.","","$C(7),!!")
.D EN^DDIOL("","","!!")
;
;Warn of In Process, Only delete if answered Yes ;*259
I $$REFIP^PSOUTLA1(DA(1),DA,"R") D I 'Y Q ;reset $T
. D EN^DDIOL("** Refill has previously been sent to the External Dispense Machine","","!!,?2")
. D EN^DDIOL("** for filling and is still Pending Processing","","$C(7),!,?2")
. D EN^DDIOL("","","!")
. K DIR
. S DIR("A")="Do you want to continue? "
. S DIR("B")="Y"
. S DIR(0)="YA^^"
. S DIR("?")="Enter Y for Yes or N for No."
. D ^DIR
. K DIR
Q
;
WARN1 ;move to PSOUTLA1
D WARN1^PSOUTLA1
Q
;
CAN(PSOXRX) ;Clean up Rx when discontinued
N SUSD,IFN,RF,NODE,DA
Q:'$D(^PSRX(PSOXRX,0))
S DA=$O(^PS(52.5,"B",PSOXRX,0)) I DA S DIK="^PS(52.5,",SUSD=$P($G(^PS(52.5,DA,0)),"^",2) D ^DIK K DIK I $O(^PSRX(PSOXRX,1,0)) S DA=PSOXRX D REF^PSOCAN2
I $D(^PS(52.4,PSOXRX,0)) S DIK="^PS(52.4,",DA=PSOXRX D ^DIK K DIK
I $G(^PSRX(PSOXRX,"H"))]"" K:$P(^PSRX(PSOXRX,"H"),"^") ^PSRX("AH",$P(^PSRX(PSOXRX,"H"),"^"),PSOXRX) S ^PSRX(PSOXRX,"H")=""
I '$P($G(^PSRX(PSOXRX,2)),"^",2) K DIE S DIE="^PSRX(",DA=PSOXRX,DR="22///"_DT D ^DIE
Q
ECAN(PSOXRX) ;Clean up Rx when expired
N DA
Q:'$D(^PSRX(PSOXRX,0))
S DA=$O(^PS(52.5,"B",PSOXRX,0)) I DA K DIK S DIK="^PS(52.5," D ^DIK K DIK
I $D(^PS(52.4,PSOXRX,0)) K DIK S DIK="^PS(52.4,",DA=PSOXRX D ^DIK K DIK
I $G(^PSRX(PSOXRX,"H"))]"" K:$P(^PSRX(PSOXRX,"H"),"^") ^PSRX("AH",$P(^PSRX(PSOXRX,"H"),"^"),PSOXRX) S ^PSRX(PSOXRX,"H")=""
I '$P($G(^PSRX(PSOXRX,2)),"^",2) K DIE S DIE="^PSRX(",DA=PSOXRX,DR="22///"_DT D ^DIE K DA,DR
Q
CMOP ;CMOP("L")=LAST FILL... if it is orig Rx =0
;CMOP(FILL #)=CMOP status from 52[TRAN=0,DISP=1,RETRAN=2,NOT DISP=3
;If suspended CMOP("S")=CMOP suspense status Q,L,X,P,R
;All returned variables can be killed by K CMOP
;
S CRX=DA
CMOP1 N X
S (CMOP("L"),X)=0 F S X=$O(^PSRX(CRX,1,X)) Q:'X S CMOP("L")=X
I $O(^PSRX(CRX,4,0)) F X=0:0 S X=$O(^PSRX(CRX,4,X)) Q:'X D
.S CMOP($P($G(^PSRX(CRX,4,X,0)),"^",3))=$P($G(^(0)),"^",4)
S X=$O(^PS(52.5,"B",CRX,0)) I X]"" S CMOP("S")=$P($G(^PS(52.5,X,0)),"^",7)
K CRX,X
Q
;
CHKCMOP(RX,REA) ;Check if an RX is Transmitted/Retransmitted to CMOP and send alert mail
;
; Input: RX - ien to file #52
; REA - reason DC's "A" = admission, "D" = death
; Output: none
;
N CMOP,PSOCMOP
S REA=$G(REA)
I $$TRANCMOP(RX),$G(PSOCMOP)]"" D MAILCMOP(RX,PSOCMOP,REA)
Q
;
TRANCMOP(RX) ;check if a fill is Transmitted or Retransmitted
;
; Input: = RX number
; Function output:= RX number if CMOP status is Trans or Retrans
; = 0 if neither
; Global parm out:= PSOCMOP = string from call to ^PSOCMOPA
;
N DA,PSOTRANS
S DA=RX D ^PSOCMOPA
S PSOTRANS=$P($G(PSOCMOP),"^")
Q:PSOTRANS=0!(PSOTRANS=2) RX
Q 0
;
MAILCMOP(RX,STR,REA) ;Send mail message to mail group PSX EXTERNAL DISPENSE ALERTS
;
; Input: RX = ien of PSRX
; STR = CMOP STATUS # ^ TRANSMIT DATE (FM) ^ LAST FILL #
; REA = reason DC'd "A" = admission, "D" = death
; Output: none
;
N CMDT,CMST,DFN,VADM,PSOTEXT,PSOIEN,PSOKEYN,XMY,XMDUZ,XMSUB,XMTEXT
N DIV,SSN,RXO,FILL,DRUG,DIVN,MAILGRP,NAME,PRV,RXSTS
S RXO=$$GET1^DIQ(52,RX,.01)
S CMDT=$P(STR,U,2)
S CMDT=$E(CMDT,4,5)_"/"_$E(CMDT,6,7)_"/"_$E(CMDT,2,3)
S FILL=$P(STR,U,3)
S CMST=$P(STR,U),CMST=$S(CMST=2:"RETRANSMITTED",1:"TRANSMITTED")
S DIV=$P(^PSRX(RX,2),"^",9),DIVN=$P($G(^PS(59,DIV,0)),"^")
S MAILGRP="PSX EXTERNAL DISPENSE ALERTS"
S XMY("G."_MAILGRP)=""
;if no members & no member groups & no remote members, then send to
; the default: PSXCMOPMGR key holders
S PSOIEN=$O(^XMB(3.8,"B",MAILGRP,0))
I '$O(^XMB(3.8,PSOIEN,1,0))&'$O(^XMB(3.8,PSOIEN,5,0))&'$O(^XMB(3.8,PSOIEN,6,0)) D
. S PSOKEYN=0
. F S PSOKEYN=$O(^XUSEC("PSXCMOPMGR",PSOKEYN)) Q:'PSOKEYN D
. . S XMY(PSOKEYN)=""
S DFN=$$GET1^DIQ(52,RX,2,"I") D DEM^VADPT
S NAME=VADM(1)
S SSN=$P($P(VADM(2),"^",2),"-",3)
S RXSTS=$$GET1^DIQ(52,RX,100)
S DRUG=$$GET1^DIQ(52,RX,6)
S PRV=$$GET1^DIQ(52,RX,4)
S XMDUZ=.5
S XMSUB=DIVN_" - DC Alert on CMOP Rx "_RXO_" "_CMST
S PSOTEXT(1)=" Rx #: "_RXO_" Fill: "_FILL
S PSOTEXT(2)=" Patient: "_NAME_" ("_SSN_")"
S PSOTEXT(3)=" Drug: "_DRUG
S PSOTEXT(4)=" Rx Status: "_RXSTS
S:REA="A" PSOTEXT(4)=PSOTEXT(4)_" (due to Admission)"
S:REA="D" PSOTEXT(4)=PSOTEXT(4)_" (due to Date of Death)"
S PSOTEXT(5)="Processing Status: "_CMST_" to CMOP on "_CMDT
S PSOTEXT(6)=" Provider: "_PRV
S PSOTEXT(7)=""
S PSOTEXT(8)="******** Please contact CMOP or take appropriate action ********"
S XMTEXT="PSOTEXT(" D ^XMD
D KVA^VADPT
Q
;
PSOCK ;
W !!!,"*The following list of order checks is a comprehensive report of all"
W !,"Outpatient, Non-VA, and Clinic medication orders on this patient's profile."
W !,"It may include orders that are local, remote, active, pending, recently"
W !,"discontinued, or expired. Please note that the sort order and format"
W !,"displayed in this report differs from the display of MOCHA 1.0 order"
W !,"checks which occurs during order processing.*",!
Q
;
PSSDGCK ;
D ^PSSDIUTL
Q
;
PSOSUPCK(CHK) ;
I $G(PSODGCKX) Q 0
I '($P($G(^PSDRUG(CHK,0)),"^",3)["S"!($E($P($G(^PSDRUG(CHK,0)),"^",2),1,2)="XA")) K CHK Q 0
W !!,"You have selected a supply item, please select another drug"
W !,"or leave blank and hit enter for Profile Order Checks." W !
K CHK
Q 1
;
OICHK(DGCKSTA,DGCKDNM) ;only orderable item on order (no drug)
;find associated drug for orderable item
N PSORD,PSOI,PSODRUG2,DTOUT,DUOUT
S PSOI=""
I DGCKSTA="PENDING" D
.S PSORD=$P(PSOSD(DGCKSTA,DGCKDNM),"^",10) Q:PSORD=""
.S PSOI=$P($G(^PS(52.41,PSORD,0)),"^",8)
I DGCKSTA="ZNONVA" D
.S PSORD=$P(PSOSD(DGCKSTA,DGCKDNM),"^",10) Q:PSORD=""
.I $G(DFN)]"" S PSOI=$P(^PS(55,DFN,"NVA",PSORD,0),"^")
I PSOI]"" D
.S PSODRUG2=$$DRG^PSSDSAPM(PSOI,"O") Q:PSODRUG2=""
.S Y=$P(PSODRUG2,";"),DIC=50,DIC(0)="MQZV",X=+Y D ^DIC K DIC,DTOUT,DUOUT
K PSORD,PSOI,PSODRUG2
Q
;
DISCK(PSRX) ;
;screen out discontinued Rx's greater than business rule calculation
;(cancel date + days supply + 7 days)
N X,Y,X1,X2
S X1=$P($G(^PSRX(PSRX,3)),"^",5),X2=(+$P(^PSRX(PSRX,0),"^",8)+7)
D C^%DTC
I DT>X Q 1
Q 0
;
PRFLP ;
N PSODRUG,PSODGCRX,PSOALLGY,PSODRIEN,PSODATA,PSRX
S (DGCKSTA,DGCKDNM)="",PSODGCKF=1
I $D(PSOSD) D
.F S DGCKSTA=$O(PSOSD(DGCKSTA)) Q:DGCKSTA="" F S DGCKDNM=$O(PSOSD(DGCKSTA,DGCKDNM)) Q:DGCKDNM="" D
..S DIC=50,DIC(0)="MQZV",X=DGCKDNM D ^DIC K DIC
..S DIC=50,DIC(0)="MQZV",X=+Y D ^DIC K DIC
..I Y=-1 D
...;for pending or non-VA orders, only an orderable item might be on the order
...D OICHK(DGCKSTA,DGCKDNM)
..I Y=-1!(Y="") Q
..;check business rule for discontinued orders
..I DGCKSTA="DISCONTINUED" S PSRX=$P(PSOSD(DGCKSTA,DGCKDNM),"^") I $$DISCK(PSRX) Q
..S PSODRUG("IEN")=$P(Y,"^"),PSODRUG("VA CLASS")=$P(Y(0),"^",2),PSODRUG("NAME")=$P(Y(0),"^")
..I '$D(PSOALLGY(DGCKDNM,PSODRUG("IEN"))) S PSOALLGY(DGCKDNM,PSODRUG("IEN"))=PSODRUG("VA CLASS")_"^"_PSODRUG("NAME")_"^"_$P(PSOSD(DGCKSTA,DGCKDNM),"^")
.S (DGCKDNM,PSODRIEN)=""
.F S DGCKDNM=$O(PSOALLGY(DGCKDNM)) Q:DGCKDNM="" F S PSODRIEN=$O(PSOALLGY(DGCKDNM,PSODRIEN)) Q:PSODRIEN="" D
..S PSODRUG("IEN")=PSODRIEN,PSODATA="",PSODATA=PSOALLGY(DGCKDNM,PSODRIEN)
..S PSODRUG("VA CLASS")=$P(PSODATA,"^"),PSODRUG("NAME")=$P(PSODATA,"^",2)
..S:+$G(^PSDRUG(PSODRUG("IEN"),2)) PSODRUG("OI")=+$G(^(2)),PSODRUG("OIN")=$P(^PS(50.7,+$G(^(2)),0),"^")
..S PSODRUG("NDF")=$S($G(^PSDRUG(PSODRUG("IEN"),"ND"))]"":+^("ND")_"A"_$P(^("ND"),"^",3),1:0)
..S PSODFN=DFN S PSODGCRX=$P(PSODATA,"^",3)
..D ^PSODGAL1
..K X,Y,DTOUT,DUOUT
K DGCKSTA,DGCKDNM,PSODGCKF,X,Y,DTOUT,DUOUT
Q
;
TITRX(RX) ; Returns the titration/maintenance flags
;
I '$G(RX) Q ""
I '$D(^PSRX(RX,0)) Q ""
I $$GET1^DIQ(52,RX,45.1,"I") Q "m"
I $$GET1^DIQ(52,RX,45.2,"I")!$$GET1^DIQ(52,RX,45.3,"I") Q "t"
Q ""
;
LTHEN(RX) ; Looks for a THEN anywhere in the Complex Order.
; Returns: 1 if found and 0 if not found. Complex Order must contain at least one THEN conjunction
; in order to mark it as a Titration Rx.
N PSOCOUNT,PSOTHEN,FNDTHEN
S (PSOCOUNT,PSOTHEN,FNDTHEN)=""
F S PSOCOUNT=$O(^PSRX(RX,6,PSOCOUNT)) Q:PSOCOUNT=""!(FNDTHEN'="") D
. S PSOTHEN=$P($G(^PSRX(RX,6,PSOCOUNT,0)),"^",6)
. I PSOTHEN="T" S FNDTHEN=1 Q
I $G(FNDTHEN)="" Q 0
Q 1
;
CONJ(PSOCRX) ;Looks for EXCEPT conjunction; EXCEPT conjunction disabled with PSO*7*477
;Returns 1 if EXCEPT conjunction found or 0 (zero) if not found
Q:'$D(^PSRX(+$G(PSOCRX),0))
N DOSEIEN,DOSE1,EXCEPT
F DOSEIEN=0:0 S DOSEIEN=$O(^PSRX(PSOCRX,6,DOSEIEN)) Q:'DOSEIEN D
. S DOSE1=^PSRX(PSOCRX,6,DOSEIEN,0)
. I $P(DOSE1,"^",6)="X" S EXCEPT=1
Q:$G(EXCEPT) 1
Q 0
;
CSID() ; Determinte if the ISSUE DATE is for a CS or non-CS (Internal to this routine only)
;Output: 1 - CS | 0 - non-CS
N CSID,DRGIEN,DEA S CSID=0
; DA will be defined when called from DD Input Transform for ISSUE DATE field (#1) on the PRESCRIPTION file (#52), except DIR call
I $G(DA),$D(^PSRX(DA,0)) S DRGIEN=$$GET1^DIQ(52,DA,6,"I")
; PSODRUG("IEN") would be defined during New Order entry
I '$G(DRGIEN),$G(PSODRUG("IEN")) S DRGIEN=PSODRUG("IEN")
;
I $G(DRGIEN) D
. S DEA=$$GET1^DIQ(50,DRGIEN,3)
. I (DEA["2")!(DEA["3")!(DEA["4")!(DEA["5") S CSID=1
;
Q CSID
;
CSRX(RXIEN) ; Controlled Substance Rx?
; Input: RXIEN - PRESCRIPTION file (#52) pointer
;Output: $$CS - 1:YES / 0:NO
N DRGIEN,DEA
S DRGIEN=$$GET1^DIQ(52,RXIEN,6,"I") I 'DRGIEN Q 0
S DEA=$$GET1^DIQ(50,DRGIEN,3)
I (DEA["2")!(DEA["3")!(DEA["4")!(DEA["5") Q 1
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOUTL 17910 printed Dec 13, 2024@02:36:06 Page 2
PSOUTL ;BHAM ISC/SAB - PSO utility routine ;Jun 22, 2018@08:18
+1 ;;7.0;OUTPATIENT PHARMACY;**1,21,126,174,218,259,324,390,313,411,466,477,626,639,692**;DEC 1997;Build 4
+2 ;External reference to $$SERV^IBARX1 supported by DBIA 2245
+3 ;External reference to ^PS(55 supported by DBIA 2228
+4 ;External reference to ^PSSDIUTL supported by DBIA 5737
+5 ;External reference to ^DD("DD" supported by DBIA 999
+6 ;External reference to ^PS(50.7 supported by DBIA 2223
+7 ;External reference to ^PSSDSAPM supported by DBIA 5570
+8 ;
+9 ;*218 prevent refill from being deleted if pending processing via
+10 ; external dispense machines
+11 ;*259 reverse *218 restrictions & Add del only last refill logic.
+12 ;
SUSPCAN ;dcl rx from suspense used in new, renew AND verification of Rxs
+1 SET PSLAST=0
FOR PSI=0:0
SET PSI=$ORDER(^PSRX(PSRX,1,PSI))
if 'PSI
QUIT
SET PSLAST=PSI
+2 IF PSLAST
SET PSI=^PSRX(PSRX,1,PSLAST,0)
KILL ^PSRX(PSRX,1,PSLAST),^PSRX(PSRX,1,"B",+PSI,PSLAST)
SET ^(0)=$PIECE(^PSRX(PSRX,1,0),"^",1,3)_"^"_($PIECE(^(0),"^",4)-1)
KILL PSLAST,PSI,SUSX,SUS1,SUS2
QUIT
+3 SET $PIECE(^PSRX(PSRX,3),"^",7)="DISCONTINUED FROM SUSPENSE BEFORE FILLING"
KILL PSI,SUSX,SUS1,SUS2
QUIT
+4 ;
ACTLOG ;
+1 NEW PSS
+2 FOR PSI=0:0
SET PSI=$ORDER(^PSRX(PSRX,"A",PSI))
IF 'PSI!'$ORDER(^(PSI))
SET ^PSRX(PSRX,"A",+PSI+1,0)=DT_"^"_PSREA_"^"_PSOCLC_"^"_PSRXREF_"^"_PSMSG
SET ^PSRX(PSRX,"A",0)="^52.3DA^"_(+PSI+1)_"^"_(+PSI+1)
QUIT
ACTOUT IF PSREA="C"
SET PSI=$SELECT($DATA(^PSRX(PSRX,2)):+$PIECE(^(2),"^",6),1:0)
if $DATA(^PS(55,PSDFN,"P","A",PSI,PSRX))
KILL ^(PSRX)
SET ^PS(55,PSDFN,"P","A",DT,PSRX)=""
QUIT
+1 IF PSREA="R"
FOR PSI=0:0
SET PSI=$ORDER(^PSRX(PSRX,"A",PSI))
if 'PSI
QUIT
IF $DATA(^(PSI,0))
IF $PIECE(^(0),"^",2)="C"
SET PSS=+^(0)
+2 IF $DATA(PSS)
IF PSS
if $DATA(^PS(55,PSDFN,"P","A",PSS,PSRX))
KILL ^(PSRX)
+3 IF PSREA="R"
IF $DATA(^PSRX(PSRX,2))#2
SET ^PS(55,PSDFN,"P","A",+$PIECE(^PSRX(PSRX,2),"^",6),PSRX)=""
+4 QUIT
+5 ;
QUES ;INSTRUCTIONS FOR RENEW AND REFILL
+1 WRITE !?5,"Enter the item #(s) or RX #(s) you wish to ",$SELECT(PSFROM="N":"renew ",PSFROM="R":"REFILL "),"separated by commas."
+2 WRITE !?5,"For example: 1,2,5 or 123456,33254A,232323B."
+3 WRITE !?5,"Do not enter the same number twice, duplicates are not allowed."
+4 QUIT
ENDVCHK NEW ANS,PSPOP
SET PSPOP=0
if 'PSODIV
QUIT
if '$PIECE(^PSRX(PSRX,2),"^",9)!($PIECE(^(2),"^",9)=PSOSITE)
QUIT
CHK1 IF '$PIECE(PSOSYS,"^",2)
WRITE !?10,$CHAR(7),"RX# ",$PIECE(^PSRX(PSRX,0),"^")," is not a valid choice. (Different Division)"
SET PSPOP=1
QUIT
+1 IF $PIECE(PSOSYS,"^",3)
WRITE !?10,$CHAR(7),"RX# ",$PIECE(^PSRX(PSRX,0),"^")," is from another division. Continue? (Y/N) "
READ ANS:DTIME
IF ANS="^"!(ANS="")
SET PSPOP=1
QUIT
+2 IF (ANS']"")!("YNyn"'[$EXTRACT(ANS))
WRITE !?10,$CHAR(7),"Answer 'YES' or 'NO'."
GOTO CHK1
+3 if $EXTRACT(ANS)["Nn"
SET PSPOP=1
QUIT
+4 ;PSO*7*259; SET VAR PSOSFN TO CHECK FOR SUSPENDED REFILL
K52 KILL PSOSFN
SET SFN=+$ORDER(^PS(52.5,"B",DA(1),0))
SET PSOSFN=SFN
if SFN=0
QUIT
+1 IF $PIECE($GET(^PS(52.5,SFN,0)),"^",5)=$PIECE($GET(^PSRX(+^PS(52.5,SFN,0),"P",0)),"^",3)
IF $PIECE($GET(^PSRX($PIECE(^PS(52.5,SFN,0),"^"),"P",0)),"^",4)=0
NEW PSOXX
SET PSOXX=1
GOTO KILL
+2 if X'=""&($GET(Y)=1)
GOTO KILL
IF $GET(Y)'=1
IF SFN
IF $DATA(^PS(52.5,SFN,0))
IF '$PIECE(^(0),"^",5)
IF '$PIECE($GET(^("P")),"^")
Begin DoDot:1
+3 SET SDT=+$PIECE(^PS(52.5,SFN,0),"^",2)
KILL ^PS(52.5,"C",SDT,SFN)
+4 IF $PIECE($GET(^PS(52.5,SFN,0)),"^",7)="Q"
KILL ^PS(52.5,"AQ",SDT,+$PIECE(^PS(52.5,SFN,0),"^",3),SFN)
DO KCMPX^PSOCMOP(SFN,"Q")
+5 IF $PIECE($GET(^PS(52.5,SFN,0)),"^",7)=""
KILL ^PS(52.5,"AC",+$PIECE(^PS(52.5,SFN,0),"^",3),SDT,SFN)
+6 KILL SFN,SDT
End DoDot:1
+7 QUIT
S52 SET (RIFN,PSOSX)=0
FOR
SET RIFN=$ORDER(^PSRX(DA(1),1,RIFN))
if 'RIFN
QUIT
SET RFID=$PIECE(^PSRX(DA(1),1,RIFN,0),"^")
SET PSOSX=PSOSX+1
+1 SET SFN=+$ORDER(^PS(52.5,"B",DA(1),0))
IF SFN
IF '$GET(^PS(52.5,SFN,"P"))
IF $PIECE($GET(^PSRX($PIECE($GET(^PS(52.5,SFN,0)),"^"),"STA")),"^")=5
Begin DoDot:1
+2 IF '$DATA(^PS(52.5,SFN,0))!($PIECE($GET(^(0)),"^",5))
QUIT
+3 SET $PIECE(^PS(52.5,SFN,0),"^",2)=RFID
SET ^PS(52.5,"C",RFID,SFN)=""
+4 IF $PIECE($GET(^PS(52.5,SFN,0)),"^",7)="Q"
SET ^PS(52.5,"AQ",RFID,+$PIECE(^PS(52.5,SFN,0),"^",3),SFN)=""
DO SCMPX^PSOCMOP(SFN,"Q")
+5 IF $PIECE($GET(^PS(52.5,SFN,0)),"^",7)=""
SET ^PS(52.5,"AC",+$PIECE(^PS(52.5,SFN,0),"^",3),RFID,SFN)=""
End DoDot:1
+6 KILL SFN,RIFN,RFID,PSOSX,PSOSXDT
QUIT
KILL NEW DFN
+1 IF SFN
Begin DoDot:1
+2 SET $PIECE(^PSRX(DA(1),"STA"),"^")=0
if '$DATA(^PS(52.5,SFN,0))
QUIT
SET DFN=+$PIECE(^PS(52.5,SFN,0),"^",3)
SET PAT=$PIECE(^DPT(DFN,0),"^")
+3 ;I $P(^PS(52.5,SFN,0),"^",5) Q
+4 KILL ^PS(52.5,"B",+$PIECE(^PS(52.5,SFN,0),"^"),SFN),^PS(52.5,"C",+$PIECE(^PS(52.5,SFN,0),"^",2),SFN),^PS(52.5,"D",PAT,SFN),^PS(52.5,"AF",DFN,SFN)
+5 IF $PIECE($GET(^PS(52.5,SFN,0)),"^",7)=""
Begin DoDot:2
+6 IF $GET(^PS(52.5,SFN,"P"))
KILL ^PS(52.5,"AS",+$PIECE(^(0),"^",8),+$PIECE(^(0),"^",9),+$PIECE(^(0),"^",6),+$PIECE(^(0),"^",11),SFN),^PS(52.5,"ADL",$EXTRACT(+$PIECE(^PS(52.5,SFN,0),"^",8),1,7),SFN)
QUIT
+7 KILL ^PS(52.5,"AC",DFN,+$PIECE(^PS(52.5,SFN,0),"^",2),SFN)
End DoDot:2
+8 IF $PIECE($GET(^PS(52.5,SFN,0)),"^",7)'=""
Begin DoDot:2
+9 ;Kill CMOP xrefs
+10 NEW PSOC7
SET PSOC7=$PIECE($GET(^PS(52.5,SFN,0)),"^",7)
+11 IF PSOC7="Q"!(PSOC7="P")
KILL ^PS(52.5,"AG",+$PIECE(^PS(52.5,SFN,0),"^",3),SFN)
DO KCMPX^PSOCMOP(SFN,PSOC7)
+12 IF PSOC7="X"!(PSOC7="P")!(PSOC7="L")
KILL ^PS(52.5,$SELECT(PSOC7="X":"AX",PSOC7="P":"AP",1:"AL"),$PIECE(^PS(52.5,SFN,0),"^",2),$PIECE(^(0),"^",3),SFN)
DO KCMPX^PSOCMOP(SFN,PSOC7)
+13 KILL ^PS(52.5,"APR",+$PIECE(^PS(52.5,SFN,0),"^",8),+$PIECE(^(0),"^",9),+$PIECE(^(0),"^",6),+$PIECE(^(0),"^",11),SFN),^PS(52.5,"ADL",$EXTRACT(+$PIECE(^PS(52.5,SFN,0),"^",8),1,7),SFN)
End DoDot:2
+14 KILL ^PS(52.5,SFN,0),^PS(52.5,SFN,"P"),DFN,SFN,PAT
End DoDot:1
+15 SET CNT=0
FOR SUB=0:0
SET SUB=$ORDER(^PSRX(DA(1),"A",SUB))
if 'SUB
QUIT
SET CNT=SUB
+16 if DA>5
SET DA=DA+1
DO NOW^%DTC
SET CNT=CNT+1
+17 SET ^PSRX(DA(1),"A",0)="^52.3DA^"_CNT_"^"_CNT
SET ^PSRX(DA(1),"A",CNT,0)=%_"^D^"_DUZ_"^"_DA_"^"
+18 IF '$DATA(PSOXX)
SET ^PSRX(DA(1),"A",CNT,0)=^PSRX(DA(1),"A",CNT,0)_"Refill "
+19 ;if PSOXX not exist, = refill. otherwise, it is a partial.
+20 SET ^PSRX(DA(1),"A",CNT,0)=^PSRX(DA(1),"A",CNT,0)_$SELECT($GET(RESK):"returned to stock.",$GET(PSOPSDAL):"deleted during Controlled Subs release.",$GET(PSOXX)=1:"Partial deleted from suspense file.",1:"deleted during Rx edit.")
KILL CNT,SUB
+21 QUIT
CID ;calculates six months limit on issue dates
+1 SET PSID=X
SET X=$SELECT($$CSID():"T-6M",1:"T-12M")
SET %DT="X"
DO ^%DT
SET %DT(0)=Y
SET X=PSID
SET %DT="EX"
DO ^%DT
KILL PSID
+2 QUIT
CIDH SET X=$SELECT($$CSID():"T-6M",1:"T-12M")
SET %DT="X"
DO ^%DT
XECUTE ^DD("DD")
DO EN^DDIOL("Issue Date must be greater or equal to "_Y,"","!")
+1 QUIT
SPR FOR RF=0:0
SET RF=$ORDER(^PSRX(DA(1),1,RF))
if 'RF
QUIT
SET NODE=RF
+1 IF NODE=1
SET $PIECE(^PSRX(DA(1),3),"^",4)=$PIECE(^PSRX(DA(1),2),"^",2)
QUIT
SREF IF $GET(NODE)
SET NODE=NODE-1
if '$DATA(^PSRX(DA(1),1,NODE,0))
GOTO SREF
+1 IF NODE=0
SET $PIECE(^PSRX(DA(1),3),"^",4)=$PIECE(^PSRX(DA(1),2),"^",2)
QUIT
+2 SET $PIECE(^PSRX(DA(1),3),"^",4)=$PIECE(^PSRX(DA(1),1,NODE,0),"^",1)
QUIT
+3 KILL NODE,RF
+4 QUIT
KPR FOR RF=0:0
SET RF=$ORDER(^PSRX(DA(1),1,RF))
if 'RF
QUIT
SET NODE=RF
+1 IF NODE=DA&(X'="")
SET NODE=NODE-1
if NODE=1
SET NODE=0
if 'NODE
GOTO ORIG
if NODE>1
GOTO KREF
+2 IF NODE=1
SET $PIECE(^PSRX(DA(1),3),"^",4)=$PIECE(^PSRX(DA(1),2),"^",2)
GOTO EX
KREF SET NODE=NODE-1
if 'NODE
GOTO EX
+1 IF NODE=1
SET $PIECE(^PSRX(DA(1),3),"^",4)=$PIECE(^PSRX(DA(1),2),"^",2)
GOTO EX
+2 if NODE=DA&(X'="")
GOTO KREF
if '$DATA(^PSRX(DA(1),1,NODE,0))
GOTO KREF
ORIG IF 'NODE
SET $PIECE(^PSRX(DA(1),3),"^",4)=$PIECE(^PSRX(DA(1),2),"^",2)
GOTO EX
+1 SET $PIECE(^PSRX(DA(1),3),"^",4)=$PIECE(^PSRX(DA(1),1,NODE,0),"^",1)
GOTO EX
EX KILL NODE,RF
+1 QUIT
IBSS NEW PSOHLP
SET PSOHLP(1,"F")="!!"
+1 SET PSOHLP(1)="Entry in this field must match the SERVICE field for pharmacy action"
+2 SET PSOHLP(2,"F")="!"
+3 SET PSOHLP(2)="types in the IB ACTION TYPE file AND be a valid entry in your"
+4 SET PSOHLP(3,"F")="!"
+5 SET PSOHLP(3)="SERVICE/SECTION file to generate copay charges!"
+6 SET PSOHLP(4,"F")="!!"
+7 DO EN^DDIOL(.PSOHLP)
KILL PSOHLP
+8 QUIT
IBSSR NEW PSOIBFL,PSOIBLP,PSOIBST
SET PSOIBFL=0
+1 FOR PSOIBLP=0:0
SET PSOIBLP=$ORDER(^DIC(49,PSOIBLP))
if 'PSOIBLP!(PSOIBFL)
QUIT
SET Y=PSOIBLP
SET PSOIBST=$$SERV^IBARX1(+Y)
IF $GET(PSOIBST)
SET DIE="^PS(59,"
SET DA=PSOSITE
SET DR="1003////"_PSOIBLP
DO ^DIE
KILL DIE
Begin DoDot:1
+2 WRITE $CHAR(7),!!,"There was an invalid entry in your IB SERVICE/SECTION field in your Outpatient",!,"Site Parameter file, but we have fixed the problem for you, and you",!,"may continue!"
QUIT
End DoDot:1
SET PSOIBFL=1
+3 QUIT
WARN ;
+1 IF $GET(PSOUNHLD)
Begin DoDot:1
+2 DO EN^DDIOL("You cannot delete a refill while removing from Hold! Use the Edit Action.","","$C(7),!!")
DO EN^DDIOL(" ","","!!")
End DoDot:1
QUIT
+3 IF $GET(CMOP(DA))]""&(+$GET(CMOP(DA))<3)
Begin DoDot:1
+4 DO EN^DDIOL("You cannot delete a refill that"_$SELECT(+$GET(CMOP(DA))=1:" has been released by",1:" is being transmitted to")_" the CMOP","","!!")
+5 DO EN^DDIOL(" ","","!!")
End DoDot:1
KILL CMOP
QUIT
+6 KILL CMOP
+7 ;
+8 NEW PSOL,PSR
+9 SET PSR=0
FOR
SET PSR=$ORDER(^PSRX(DA(1),1,PSR))
if 'PSR
QUIT
SET PSOL=PSR
+10 IF DA=PSOL
IF $PIECE(^PSRX(DA(1),1,DA,0),"^",18)
Begin DoDot:1
+11 DO EN^DDIOL("Refill Released! Use the 'Return to Stock' option!","","$C(7),!!")
DO EN^DDIOL(" ","","!")
End DoDot:1
QUIT
+12 ;
+13 ;Only allow deletion if last refill *259
+14 IF $ORDER(^PSRX(DA(1),1,DA))
Begin DoDot:1
+15 DO EN^DDIOL("Only the last refill can be deleted. Later refills must be deleted first.","","$C(7),!!")
+16 DO EN^DDIOL("","","!!")
End DoDot:1
QUIT
+17 ;
+18 ;Warn of In Process, Only delete if answered Yes ;*259
+19 ;reset $T
IF $$REFIP^PSOUTLA1(DA(1),DA,"R")
Begin DoDot:1
+20 DO EN^DDIOL("** Refill has previously been sent to the External Dispense Machine","","!!,?2")
+21 DO EN^DDIOL("** for filling and is still Pending Processing","","$C(7),!,?2")
+22 DO EN^DDIOL("","","!")
+23 KILL DIR
+24 SET DIR("A")="Do you want to continue? "
+25 SET DIR("B")="Y"
+26 SET DIR(0)="YA^^"
+27 SET DIR("?")="Enter Y for Yes or N for No."
+28 DO ^DIR
+29 KILL DIR
End DoDot:1
IF 'Y
QUIT
+30 QUIT
+31 ;
WARN1 ;move to PSOUTLA1
+1 DO WARN1^PSOUTLA1
+2 QUIT
+3 ;
CAN(PSOXRX) ;Clean up Rx when discontinued
+1 NEW SUSD,IFN,RF,NODE,DA
+2 if '$DATA(^PSRX(PSOXRX,0))
QUIT
+3 SET DA=$ORDER(^PS(52.5,"B",PSOXRX,0))
IF DA
SET DIK="^PS(52.5,"
SET SUSD=$PIECE($GET(^PS(52.5,DA,0)),"^",2)
DO ^DIK
KILL DIK
IF $ORDER(^PSRX(PSOXRX,1,0))
SET DA=PSOXRX
DO REF^PSOCAN2
+4 IF $DATA(^PS(52.4,PSOXRX,0))
SET DIK="^PS(52.4,"
SET DA=PSOXRX
DO ^DIK
KILL DIK
+5 IF $GET(^PSRX(PSOXRX,"H"))]""
if $PIECE(^PSRX(PSOXRX,"H"),"^")
KILL ^PSRX("AH",$PIECE(^PSRX(PSOXRX,"H"),"^"),PSOXRX)
SET ^PSRX(PSOXRX,"H")=""
+6 IF '$PIECE($GET(^PSRX(PSOXRX,2)),"^",2)
KILL DIE
SET DIE="^PSRX("
SET DA=PSOXRX
SET DR="22///"_DT
DO ^DIE
+7 QUIT
ECAN(PSOXRX) ;Clean up Rx when expired
+1 NEW DA
+2 if '$DATA(^PSRX(PSOXRX,0))
QUIT
+3 SET DA=$ORDER(^PS(52.5,"B",PSOXRX,0))
IF DA
KILL DIK
SET DIK="^PS(52.5,"
DO ^DIK
KILL DIK
+4 IF $DATA(^PS(52.4,PSOXRX,0))
KILL DIK
SET DIK="^PS(52.4,"
SET DA=PSOXRX
DO ^DIK
KILL DIK
+5 IF $GET(^PSRX(PSOXRX,"H"))]""
if $PIECE(^PSRX(PSOXRX,"H"),"^")
KILL ^PSRX("AH",$PIECE(^PSRX(PSOXRX,"H"),"^"),PSOXRX)
SET ^PSRX(PSOXRX,"H")=""
+6 IF '$PIECE($GET(^PSRX(PSOXRX,2)),"^",2)
KILL DIE
SET DIE="^PSRX("
SET DA=PSOXRX
SET DR="22///"_DT
DO ^DIE
KILL DA,DR
+7 QUIT
CMOP ;CMOP("L")=LAST FILL... if it is orig Rx =0
+1 ;CMOP(FILL #)=CMOP status from 52[TRAN=0,DISP=1,RETRAN=2,NOT DISP=3
+2 ;If suspended CMOP("S")=CMOP suspense status Q,L,X,P,R
+3 ;All returned variables can be killed by K CMOP
+4 ;
+5 SET CRX=DA
CMOP1 NEW X
+1 SET (CMOP("L"),X)=0
FOR
SET X=$ORDER(^PSRX(CRX,1,X))
if 'X
QUIT
SET CMOP("L")=X
+2 IF $ORDER(^PSRX(CRX,4,0))
FOR X=0:0
SET X=$ORDER(^PSRX(CRX,4,X))
if 'X
QUIT
Begin DoDot:1
+3 SET CMOP($PIECE($GET(^PSRX(CRX,4,X,0)),"^",3))=$PIECE($GET(^(0)),"^",4)
End DoDot:1
+4 SET X=$ORDER(^PS(52.5,"B",CRX,0))
IF X]""
SET CMOP("S")=$PIECE($GET(^PS(52.5,X,0)),"^",7)
+5 KILL CRX,X
+6 QUIT
+7 ;
CHKCMOP(RX,REA) ;Check if an RX is Transmitted/Retransmitted to CMOP and send alert mail
+1 ;
+2 ; Input: RX - ien to file #52
+3 ; REA - reason DC's "A" = admission, "D" = death
+4 ; Output: none
+5 ;
+6 NEW CMOP,PSOCMOP
+7 SET REA=$GET(REA)
+8 IF $$TRANCMOP(RX)
IF $GET(PSOCMOP)]""
DO MAILCMOP(RX,PSOCMOP,REA)
+9 QUIT
+10 ;
TRANCMOP(RX) ;check if a fill is Transmitted or Retransmitted
+1 ;
+2 ; Input: = RX number
+3 ; Function output:= RX number if CMOP status is Trans or Retrans
+4 ; = 0 if neither
+5 ; Global parm out:= PSOCMOP = string from call to ^PSOCMOPA
+6 ;
+7 NEW DA,PSOTRANS
+8 SET DA=RX
DO ^PSOCMOPA
+9 SET PSOTRANS=$PIECE($GET(PSOCMOP),"^")
+10 if PSOTRANS=0!(PSOTRANS=2)
QUIT RX
+11 QUIT 0
+12 ;
MAILCMOP(RX,STR,REA) ;Send mail message to mail group PSX EXTERNAL DISPENSE ALERTS
+1 ;
+2 ; Input: RX = ien of PSRX
+3 ; STR = CMOP STATUS # ^ TRANSMIT DATE (FM) ^ LAST FILL #
+4 ; REA = reason DC'd "A" = admission, "D" = death
+5 ; Output: none
+6 ;
+7 NEW CMDT,CMST,DFN,VADM,PSOTEXT,PSOIEN,PSOKEYN,XMY,XMDUZ,XMSUB,XMTEXT
+8 NEW DIV,SSN,RXO,FILL,DRUG,DIVN,MAILGRP,NAME,PRV,RXSTS
+9 SET RXO=$$GET1^DIQ(52,RX,.01)
+10 SET CMDT=$PIECE(STR,U,2)
+11 SET CMDT=$EXTRACT(CMDT,4,5)_"/"_$EXTRACT(CMDT,6,7)_"/"_$EXTRACT(CMDT,2,3)
+12 SET FILL=$PIECE(STR,U,3)
+13 SET CMST=$PIECE(STR,U)
SET CMST=$SELECT(CMST=2:"RETRANSMITTED",1:"TRANSMITTED")
+14 SET DIV=$PIECE(^PSRX(RX,2),"^",9)
SET DIVN=$PIECE($GET(^PS(59,DIV,0)),"^")
+15 SET MAILGRP="PSX EXTERNAL DISPENSE ALERTS"
+16 SET XMY("G."_MAILGRP)=""
+17 ;if no members & no member groups & no remote members, then send to
+18 ; the default: PSXCMOPMGR key holders
+19 SET PSOIEN=$ORDER(^XMB(3.8,"B",MAILGRP,0))
+20 IF '$ORDER(^XMB(3.8,PSOIEN,1,0))&'$ORDER(^XMB(3.8,PSOIEN,5,0))&'$ORDER(^XMB(3.8,PSOIEN,6,0))
Begin DoDot:1
+21 SET PSOKEYN=0
+22 FOR
SET PSOKEYN=$ORDER(^XUSEC("PSXCMOPMGR",PSOKEYN))
if 'PSOKEYN
QUIT
Begin DoDot:2
+23 SET XMY(PSOKEYN)=""
End DoDot:2
End DoDot:1
+24 SET DFN=$$GET1^DIQ(52,RX,2,"I")
DO DEM^VADPT
+25 SET NAME=VADM(1)
+26 SET SSN=$PIECE($PIECE(VADM(2),"^",2),"-",3)
+27 SET RXSTS=$$GET1^DIQ(52,RX,100)
+28 SET DRUG=$$GET1^DIQ(52,RX,6)
+29 SET PRV=$$GET1^DIQ(52,RX,4)
+30 SET XMDUZ=.5
+31 SET XMSUB=DIVN_" - DC Alert on CMOP Rx "_RXO_" "_CMST
+32 SET PSOTEXT(1)=" Rx #: "_RXO_" Fill: "_FILL
+33 SET PSOTEXT(2)=" Patient: "_NAME_" ("_SSN_")"
+34 SET PSOTEXT(3)=" Drug: "_DRUG
+35 SET PSOTEXT(4)=" Rx Status: "_RXSTS
+36 if REA="A"
SET PSOTEXT(4)=PSOTEXT(4)_" (due to Admission)"
+37 if REA="D"
SET PSOTEXT(4)=PSOTEXT(4)_" (due to Date of Death)"
+38 SET PSOTEXT(5)="Processing Status: "_CMST_" to CMOP on "_CMDT
+39 SET PSOTEXT(6)=" Provider: "_PRV
+40 SET PSOTEXT(7)=""
+41 SET PSOTEXT(8)="******** Please contact CMOP or take appropriate action ********"
+42 SET XMTEXT="PSOTEXT("
DO ^XMD
+43 DO KVA^VADPT
+44 QUIT
+45 ;
PSOCK ;
+1 WRITE !!!,"*The following list of order checks is a comprehensive report of all"
+2 WRITE !,"Outpatient, Non-VA, and Clinic medication orders on this patient's profile."
+3 WRITE !,"It may include orders that are local, remote, active, pending, recently"
+4 WRITE !,"discontinued, or expired. Please note that the sort order and format"
+5 WRITE !,"displayed in this report differs from the display of MOCHA 1.0 order"
+6 WRITE !,"checks which occurs during order processing.*",!
+7 QUIT
+8 ;
PSSDGCK ;
+1 DO ^PSSDIUTL
+2 QUIT
+3 ;
PSOSUPCK(CHK) ;
+1 IF $GET(PSODGCKX)
QUIT 0
+2 IF '($PIECE($GET(^PSDRUG(CHK,0)),"^",3)["S"!($EXTRACT($PIECE($GET(^PSDRUG(CHK,0)),"^",2),1,2)="XA"))
KILL CHK
QUIT 0
+3 WRITE !!,"You have selected a supply item, please select another drug"
+4 WRITE !,"or leave blank and hit enter for Profile Order Checks."
WRITE !
+5 KILL CHK
+6 QUIT 1
+7 ;
OICHK(DGCKSTA,DGCKDNM) ;only orderable item on order (no drug)
+1 ;find associated drug for orderable item
+2 NEW PSORD,PSOI,PSODRUG2,DTOUT,DUOUT
+3 SET PSOI=""
+4 IF DGCKSTA="PENDING"
Begin DoDot:1
+5 SET PSORD=$PIECE(PSOSD(DGCKSTA,DGCKDNM),"^",10)
if PSORD=""
QUIT
+6 SET PSOI=$PIECE($GET(^PS(52.41,PSORD,0)),"^",8)
End DoDot:1
+7 IF DGCKSTA="ZNONVA"
Begin DoDot:1
+8 SET PSORD=$PIECE(PSOSD(DGCKSTA,DGCKDNM),"^",10)
if PSORD=""
QUIT
+9 IF $GET(DFN)]""
SET PSOI=$PIECE(^PS(55,DFN,"NVA",PSORD,0),"^")
End DoDot:1
+10 IF PSOI]""
Begin DoDot:1
+11 SET PSODRUG2=$$DRG^PSSDSAPM(PSOI,"O")
if PSODRUG2=""
QUIT
+12 SET Y=$PIECE(PSODRUG2,";")
SET DIC=50
SET DIC(0)="MQZV"
SET X=+Y
DO ^DIC
KILL DIC,DTOUT,DUOUT
End DoDot:1
+13 KILL PSORD,PSOI,PSODRUG2
+14 QUIT
+15 ;
DISCK(PSRX) ;
+1 ;screen out discontinued Rx's greater than business rule calculation
+2 ;(cancel date + days supply + 7 days)
+3 NEW X,Y,X1,X2
+4 SET X1=$PIECE($GET(^PSRX(PSRX,3)),"^",5)
SET X2=(+$PIECE(^PSRX(PSRX,0),"^",8)+7)
+5 DO C^%DTC
+6 IF DT>X
QUIT 1
+7 QUIT 0
+8 ;
PRFLP ;
+1 NEW PSODRUG,PSODGCRX,PSOALLGY,PSODRIEN,PSODATA,PSRX
+2 SET (DGCKSTA,DGCKDNM)=""
SET PSODGCKF=1
+3 IF $DATA(PSOSD)
Begin DoDot:1
+4 FOR
SET DGCKSTA=$ORDER(PSOSD(DGCKSTA))
if DGCKSTA=""
QUIT
FOR
SET DGCKDNM=$ORDER(PSOSD(DGCKSTA,DGCKDNM))
if DGCKDNM=""
QUIT
Begin DoDot:2
+5 SET DIC=50
SET DIC(0)="MQZV"
SET X=DGCKDNM
DO ^DIC
KILL DIC
+6 SET DIC=50
SET DIC(0)="MQZV"
SET X=+Y
DO ^DIC
KILL DIC
+7 IF Y=-1
Begin DoDot:3
+8 ;for pending or non-VA orders, only an orderable item might be on the order
+9 DO OICHK(DGCKSTA,DGCKDNM)
End DoDot:3
+10 IF Y=-1!(Y="")
QUIT
+11 ;check business rule for discontinued orders
+12 IF DGCKSTA="DISCONTINUED"
SET PSRX=$PIECE(PSOSD(DGCKSTA,DGCKDNM),"^")
IF $$DISCK(PSRX)
QUIT
+13 SET PSODRUG("IEN")=$PIECE(Y,"^")
SET PSODRUG("VA CLASS")=$PIECE(Y(0),"^",2)
SET PSODRUG("NAME")=$PIECE(Y(0),"^")
+14 IF '$DATA(PSOALLGY(DGCKDNM,PSODRUG("IEN")))
SET PSOALLGY(DGCKDNM,PSODRUG("IEN"))=PSODRUG("VA CLASS")_"^"_PSODRUG("NAME")_"^"_$PIECE(PSOSD(DGCKSTA,DGCKDNM),"^")
End DoDot:2
+15 SET (DGCKDNM,PSODRIEN)=""
+16 FOR
SET DGCKDNM=$ORDER(PSOALLGY(DGCKDNM))
if DGCKDNM=""
QUIT
FOR
SET PSODRIEN=$ORDER(PSOALLGY(DGCKDNM,PSODRIEN))
if PSODRIEN=""
QUIT
Begin DoDot:2
+17 SET PSODRUG("IEN")=PSODRIEN
SET PSODATA=""
SET PSODATA=PSOALLGY(DGCKDNM,PSODRIEN)
+18 SET PSODRUG("VA CLASS")=$PIECE(PSODATA,"^")
SET PSODRUG("NAME")=$PIECE(PSODATA,"^",2)
+19 if +$GET(^PSDRUG(PSODRUG("IEN"),2))
SET PSODRUG("OI")=+$GET(^(2))
SET PSODRUG("OIN")=$PIECE(^PS(50.7,+$GET(^(2)),0),"^")
+20 SET PSODRUG("NDF")=$SELECT($GET(^PSDRUG(PSODRUG("IEN"),"ND"))]"":+^("ND")_"A"_$PIECE(^("ND"),"^",3),1:0)
+21 SET PSODFN=DFN
SET PSODGCRX=$PIECE(PSODATA,"^",3)
+22 DO ^PSODGAL1
+23 KILL X,Y,DTOUT,DUOUT
End DoDot:2
End DoDot:1
+24 KILL DGCKSTA,DGCKDNM,PSODGCKF,X,Y,DTOUT,DUOUT
+25 QUIT
+26 ;
TITRX(RX) ; Returns the titration/maintenance flags
+1 ;
+2 IF '$GET(RX)
QUIT ""
+3 IF '$DATA(^PSRX(RX,0))
QUIT ""
+4 IF $$GET1^DIQ(52,RX,45.1,"I")
QUIT "m"
+5 IF $$GET1^DIQ(52,RX,45.2,"I")!$$GET1^DIQ(52,RX,45.3,"I")
QUIT "t"
+6 QUIT ""
+7 ;
LTHEN(RX) ; Looks for a THEN anywhere in the Complex Order.
+1 ; Returns: 1 if found and 0 if not found. Complex Order must contain at least one THEN conjunction
+2 ; in order to mark it as a Titration Rx.
+3 NEW PSOCOUNT,PSOTHEN,FNDTHEN
+4 SET (PSOCOUNT,PSOTHEN,FNDTHEN)=""
+5 FOR
SET PSOCOUNT=$ORDER(^PSRX(RX,6,PSOCOUNT))
if PSOCOUNT=""!(FNDTHEN'="")
QUIT
Begin DoDot:1
+6 SET PSOTHEN=$PIECE($GET(^PSRX(RX,6,PSOCOUNT,0)),"^",6)
+7 IF PSOTHEN="T"
SET FNDTHEN=1
QUIT
End DoDot:1
+8 IF $GET(FNDTHEN)=""
QUIT 0
+9 QUIT 1
+10 ;
CONJ(PSOCRX) ;Looks for EXCEPT conjunction; EXCEPT conjunction disabled with PSO*7*477
+1 ;Returns 1 if EXCEPT conjunction found or 0 (zero) if not found
+2 if '$DATA(^PSRX(+$GET(PSOCRX),0))
QUIT
+3 NEW DOSEIEN,DOSE1,EXCEPT
+4 FOR DOSEIEN=0:0
SET DOSEIEN=$ORDER(^PSRX(PSOCRX,6,DOSEIEN))
if 'DOSEIEN
QUIT
Begin DoDot:1
+5 SET DOSE1=^PSRX(PSOCRX,6,DOSEIEN,0)
+6 IF $PIECE(DOSE1,"^",6)="X"
SET EXCEPT=1
End DoDot:1
+7 if $GET(EXCEPT)
QUIT 1
+8 QUIT 0
+9 ;
CSID() ; Determinte if the ISSUE DATE is for a CS or non-CS (Internal to this routine only)
+1 ;Output: 1 - CS | 0 - non-CS
+2 NEW CSID,DRGIEN,DEA
SET CSID=0
+3 ; DA will be defined when called from DD Input Transform for ISSUE DATE field (#1) on the PRESCRIPTION file (#52), except DIR call
+4 IF $GET(DA)
IF $DATA(^PSRX(DA,0))
SET DRGIEN=$$GET1^DIQ(52,DA,6,"I")
+5 ; PSODRUG("IEN") would be defined during New Order entry
+6 IF '$GET(DRGIEN)
IF $GET(PSODRUG("IEN"))
SET DRGIEN=PSODRUG("IEN")
+7 ;
+8 IF $GET(DRGIEN)
Begin DoDot:1
+9 SET DEA=$$GET1^DIQ(50,DRGIEN,3)
+10 IF (DEA["2")!(DEA["3")!(DEA["4")!(DEA["5")
SET CSID=1
End DoDot:1
+11 ;
+12 QUIT CSID
+13 ;
CSRX(RXIEN) ; Controlled Substance Rx?
+1 ; Input: RXIEN - PRESCRIPTION file (#52) pointer
+2 ;Output: $$CS - 1:YES / 0:NO
+3 NEW DRGIEN,DEA
+4 SET DRGIEN=$$GET1^DIQ(52,RXIEN,6,"I")
IF 'DRGIEN
QUIT 0
+5 SET DEA=$$GET1^DIQ(50,DRGIEN,3)
+6 IF (DEA["2")!(DEA["3")!(DEA["4")!(DEA["5")
QUIT 1
+7 QUIT 0
