PSOCAN2 ;BHAM ISC/JMB - modular rx cancel with speed ability drug check ;29-May-2012 14:40;PLS
;;7.0;OUTPATIENT PHARMACY;**8,18,62,46,88,164,1006,235,148,259,281,287,1015**;DEC 1997;Build 62
;External reference to ^PSDRUG supported by dbia 221
; Modified - IHS/MSC/PLS - 04/30/08 - Line HLD+2
REINS N DODR
I $P(^PSRX(DA,2),"^",6)<DT D Q
.S Y=$P(^PSRX(DA,2),"^",6) X ^DD("DD")
.W !!,"Rx: "_$P(^PSRX(DA,0),"^")_" Drug: "_$S($D(^PSDRUG($P(^PSRX(DA,0),"^",6),0)):$P(^(0),"^"),1:""),!,"Expired "_Y_" and cannot be Reinstated!",!
.D PAUSE^VALM1
I $D(^PSRX("APSOD",$P(^PSRX(DA,0),"^",2),DA)) S PSCAN($P(^PSRX(DA,0),"^"))=DA_"^R",DODR=1 D AUTOD G ACT
I $P(PSOPAR,"^",2),'$D(^XUSEC("PSORPH",DUZ)) D VERIFY D D AREC^PSOCAN1 Q
.S RX1=$P(^PSRX(DA,0),"^") S:'$D(PSCAN(RX1)) PSCAN(RX1)=DA_"^R" K RX1
ACT W ! F I=1:1:80 W "="
D ^PSOBUILD S DRG=+$P(^PSRX(DA,0),"^",6),DRG=$S($D(^PSDRUG(DRG,0)):$P(^(0),"^"),1:""),HOLDRX=RX
W !!,RX_" "_DRG D DRGDRG S RX=HOLDRX K HOLDRX Q:$P(^PSRX(+PSCAN(RX),"STA"),"^")'=12!($G(PSORX("DFLG"))) S DA=+PSCAN(RX),REA=$P(PSCAN(RX),"^",2) D CAN^PSOCAN W !
N RXIEN S RXIEN=DA
;Takes action on reinstated Rx's
S RFCNT=0 F RF=0:0 S RF=$O(^PSRX(DA,1,RF)) Q:'RF S RFCNT=RF
S (LPRT,LREF)="" F LL=0:0 S LL=$O(^PSRX(DA,"L",LL)) Q:'LL S LPRT=$P($G(^PSRX(DA,"L",LL,0)),"."),LREF=$P($G(^(0)),"^",2)
I 'RFCNT S FDT=$S($P($G(^PSRX(DA,2)),"^",2)'="":$P($G(^PSRX(DA,2)),"^",2),1:$P($G(^PSRX(DA,2)),"^")) S RELDT=$P(^(2),"^",13),RELDT=$P(RELDT,".")
I RFCNT S FDT=$P($G(^PSRX(DA,1,RFCNT,0)),"^"),RELDT=$P(^(0),"^",18),RELDT=$P(RELDT,".")
S Y=FDT D DD^%DT S XFDT=Y I RELDT'="" S Y=RELDT D DD^%DT S XRELDT=Y
I LPRT'="" S Y=LPRT D DD^%DT S XLPDT=Y
;If Rx was released, do nothing
I RELDT'="" W !,RX_" Reinstated -- ",!?3,$S('RFCNT:"Filled",1:"Refilled # "_LREF)_": "_XFDT,?32,"Printed: "_$S(LREF=RFCNT:XLPDT,1:""),?56,"Released: "_$G(XRELDT) H 3 Q
;If Rx not released, check fill/refill date for action
I $G(PSXSYS) D REINS^PSOCMOPA I $G(XFLAG) K XFLAG Q
W !,"Prescription #"_RX_" REINSTATED!"
;
N PSOTRIC S PSOTRIC="",PSOTRIC=$$TRIC^PSOREJP1(RXIEN,RFCNT,PSOTRIC)
D SUBMIT^PSOREJU3(RXIEN,RFCNT,PSOTRIC)
;
W !?3,"Prescription #",RX_": "
W !?6,$S('RFCNT:" Filled",1:" Refilled # "_LREF)_": "_XFDT," Printed: "_$S(LREF=RFCNT:XLPDT,1:"")," Released: "_$G(XRELDT),!
I FDT<DT D
.Q:$$FIND^PSOREJUT(RXIEN) ;No label for Rx's with claims rejects
.Q:PSOTRIC&($$STATUS^PSOBPSUT(RXIEN,RFCNT)'["PAYABLE") ;No labels for Tricare non-payable/in progess Rx
.S DIR("A")=" ** Do you want to print the label now",DIR("B")="N",DIR(0)="Y",DIR("?")="Enter 'Y' to print the label now. If 'N' is entered, the label may be reprinted through reprint at a later date."
.D ^DIR K DIR Q:$G(DIRUT)!('Y) S PPL=RXIEN D Q^PSORXL Q
I FDT=DT D
. Q:$$FIND^PSOREJUT(RXIEN)
. Q:PSOTRIC&($$STATUS^PSOBPSUT(RXIEN,RFCNT)'["PAYABLE")
. W !?5,"Either print the label using the reprint option "
. W !?7,"or check later to see if the label has been printed." Q
I FDT>DT&('$G(DODR)) W !?5,"Placing Rx on suspense. Please wait..." D SUS
K DODR
Q
SUS ;Adds rec to suspense
S ACT=1,RXN=DA,RX0=^PSRX(DA,0),RXS=$O(^PS(52.5,"B",DA,0)) I RXS S DA=RXS,DIK="^PS(52.5," D ^DIK S DA=RXN
S RXP=$S($D(RXP):RXP,1:0),DIC="^PS(52.5,",DIC(0)="L",X=RXN,DIC("DR")=".02///"_FDT_";.03///"_$P(RX0,"^",2)_";.04///M;.05///"_RXP_";.06////"_$G(PSOSITE)_";2///0" K DD,DO D FILE^DICN
I +$G(Y),$G(RFCNT)'="" S $P(^PS(52.5,+Y,0),"^",13)=$G(RFCNT)
S DA=RXN,$P(^PSRX(DA,"STA"),"^")=5,LFD=$E($P(^PSRX(DA,3),"^"),4,5)_"-"_$E($P(^(3),"^"),6,7)_"-"_$E($P(^(3),"^"),2,3)
S ACOM="RX Placed on Suspense until "_LFD D AREC^PSOCAN1 S ST="SC",PHST="ZS" D EN^PSOHLSN1(DA,ST,PHST,ACOM) K ST,PHST
Q
DRGDRG ;Checks for drug/drug interaction, duplicate drug and class
Q:$P(^PSRX(DA,2),"^",6)<DT
S STA="ACTIVE^NON-VERIFIED^R^HOLD^NON-VERIFIED^ACTIVE^^^^^^ACTIVE^DISCONTINUED^^DISCONTINUED^DISCONTINUED^HOLD"
S STAT=$P(STA,"^",$P(^PSRX(DA,"STA"),"^")+1)
S X=$P(^PSRX(DA,0),"^",6),DIC="^PSDRUG(",DIC(0)="MZO" D ^DIC K DIC Q:$D(DTOUT)!(Y<0)
K HOLD S NAME=$P(Y(0),"^") I +$G(PSOSD(STAT,NAME))=+PSCAN(RX) S HOLD(STAT,NAME)=$G(PSOSD(STAT,NAME)) K PSOSD(STAT,NAME)
S:$G(PSONEW("OLD VAL"))=+Y PSODRG("QFLG")=1
K PSOY S PSOY=Y,PSOY(0)=Y(0)
S PSORENW("OIRXN")=DA D SET^PSODRG,POST^PSODRG S REA=$P(PSCAN($P(^PSRX(PSORENW("OIRXN"),0),"^")),"^",2)
W ! S:$G(HOLD(STAT,NAME))]"" PSOSD(STAT,NAME)=$G(HOLD(STAT,NAME)) K HOLD,STA,STAT,PSORENW("OIRXN")
Q
VERIFY ;Put in non-verify file
S PSRXDA=DA,DIC="^PS(52.4,",DLAYGO=52.4,(X,DINUM)=PSRXDA,DIC(0)="ML",DIC("DR")="1////"_PSODFN_";2////"_DUZ_";4////"_DT
K DD,DO D FILE^DICN K DIC,DLAYGO,DINUM
S DA=PSRXDA S $P(^PSRX(DA,"STA"),"^")=1
S ST="SC",PHST="IP",VCOM="Put in non-verified status" D EN^PSOHLSN1(DA,ST,PHST,VCOM) K ST,PHST,VCOM
Q
HLD N PSDTEST,PDA,CMOP,SUSD I $P(^PSRX(DA,"STA"),"^")=3 D
.S ACOM=$S(REA="C":"Discontinued",1:"Reinstated")_" while on hold during Rx cancel. " K:$P(^PSRX(DA,"H"),"^") ^PSRX("AH",$P(^PSRX(DA,"H"),"^"),DA) S ^PSRX(DA,"H")=""
.;IHS/MSC/PLS - 04/30/08 - Next line removed to prevent Fill Date from being set.
.;I $P(^PSRX(DA,0),"^",13),'$O(^PSRX(DA,1,0)) S DIE=52,DR="22///"_$E($P(^PSRX(DA,0),"^",13),1,7) D ^DIE K DIE,DR Q
.I $P(^PSRX(DA,0),"^",13),'$O(^PSRX(DA,1,0)) Q
.S (IFN,SUSD)=0 F S IFN=$O(^PSRX(DA,1,IFN)) Q:'IFN S SUSD=IFN,RFDT=$P(^PSRX(DA,1,IFN,0),"^")
.Q:'$G(SUSD) I '$P(^PSRX(DA,1,SUSD,0),"^",18) S PSDTEST=0 D I 'PSDTEST K ^PSRX(DA,1,SUSD),^PSRX("AD",RFDT,DA,SUSD),^PSRX(DA,1,"B",RFDT,SUSD),IFN,SUSD,RFDT
..F PDA=0:0 S PDA=$O(^PSRX(DA,"L",PDA)) Q:'PDA I $P($G(^PSRX(DA,"L",PDA,0)),"^",2)=SUSD S PSDTEST=1
..K CMOP D ^PSOCMOPA I $G(CMOP(CMOP("L")))="",$G(CMOP("S"))'="L" Q
..S PSDTEST=1
Q
REF S IFN=0 F S IFN=$O(^PSRX(DA,1,IFN)) Q:'IFN I $P($G(^PSRX(DA,1,IFN,0)),"^")=SUSD,'$P(^(0),"^",18) D
.D DELREF I $G(PSORFDEL) K PSORFDEL Q
.;PSO*7*259;CHECK IF REFILL RELEASED OR LABEL PRINTED
.I $P($G(^PSRX(DA,1,IFN,0)),"^",18)]"" Q ;REFILL RELEASED
.N PSONODEL,PSOLBL S PSONODEL=0
.I $P(^PSRX(DA,"STA"),"^")=5 D REF^PSOCAN4 Q:PSONODEL
.S PSOLBL="" F S PSOLBL=$O(^PSRX(DA,"L",PSOLBL),-1) Q:'PSOLBL Q:PSONODEL Q:$P(^PSRX(DA,"L",PSOLBL,0),"^",2)<IFN I $P(^PSRX(DA,"L",PSOLBL,0),"^",2)=IFN S PSONODEL=1
.Q:PSONODEL
.K PSORFDEL K ^PSRX(DA,1,IFN),^PSRX("AD",SUSD,DA,IFN),^PSRX(DA,1,"B",SUSD,IFN)
.S $P(^PSRX(DA,1,0),"^",4)=$P(^PSRX(DA,1,0),"^",4)-1,DA(1)=DA
.S NODE=0 D SPR^PSOUTL K DA(1),RF,NODE
S IFN=0 F S IFN=$O(^PSRX(DA,1,IFN)) Q:'IFN I '$O(^PSRX(DA,1,IFN)) S $P(^PSRX(DA,3),"^")=+$P(^PSRX(DA,1,IFN,0),"^"),$P(^(3),"^",2)=SUSD
I '$O(^PSRX(DA,1,0)) S $P(^PSRX(DA,3),"^")=$P(^PSRX(DA,2),"^",2),$P(^PSRX(DA,3),"^",2)=SUSD
K IFN,SUSD
Q
KILL K %,ACNT,ACOM,ACT,ALL,BCNUM,CMOP,CNT,DA,DAYS360,DEAD,DRG,DIRUT,DR,DRUG,DTOUT,DUOUT,FDT,HOLD,I,II,IN,IT,JJ,LC,LFD,LINE,LL,LPRT,LREF,LSI,NAME,NDF,NOEXP,NSF,OUT,RXSP,EN,WARN K:'$G(POERR) INCOM
K PSODRUG,PCNT,POP,PPL,PS,PSFROM,PSINV,PLINE,PSI,PSINV,PSOCAN,PSOCMOP,PSODFN,PSODRG,PSOOPT,PSOSD,PSPOP,PSRXDA,PSS,PSVC,PSONOOR
K REA,RELDT,RF,RFDATE,RFCNT,RFL,RFL1,RFLL,RP,RX,RX0,RXCNT,RXDA,RXN,RXNUM,RXP,RXREC,RXREF,RXS,SDATE,SPCANC,SS,STAT,SUB,X,XFDT,XLPDT,XRELDT,Y D KVA^VADPT Q
DELREF ;
N RDL,PSCNODE
S PSORFDEL=0
F RDL=0:0 S RDL=$O(^PSRX(DA,4,RDL)) Q:'RDL I $G(IFN)=$P($G(^PSRX(DA,4,RDL,0)),"^",3) S PSCNODE=$G(^(0))
I $G(PSCNODE)="" Q
I +$P(PSCNODE,"^",4)<3 S PSORFDEL=1
Q
AUTOD ;reinstates Rxs dc'd by date of death
I $G(^PSRX(DA,"DDSTA"))']"" K ^PSRX("APSOD",+$P(^PSRX(DA,0),"^",2),DA),DODR Q
S DODS=$P(^PSRX(DA,"DDSTA"),"^"),DODD=$P(^("DDSTA"),"^",2,245)
S FILE=$P(DODS,";"),STA=$P(DODS,";",2)
I FILE=52.4 D Q
.S RXN=DA,^PS(52.4,DA,0)=DODD,DIK="^PS(52.4," D IX^DIK K DIK,DA S DA=RXN,$P(^PSRX(DA,"STA"),"^")=STA
.S ST="SC",PHST="IP",ACOM="Date of Death Deleted. Returned to Non-Verified status."
.K ^PSRX("APSOD",$P(^PSRX(DA,0),"^",2),DA),^PSRX(DA,"DDSTA")
.S DA=RXN D LOG D EN^PSOHLSN1(DA,ST,PHST,ACOM) K ST,PHST,ACOM,RXN
I FILE=52.5 D Q
.;Adds rec to suspense
.S RXN=DA,RXS=$O(^PS(52.5,"B",DA,0)) I RXS S DA=RXS,DIK="^PS(52.5," D ^DIK
.S DIC="^PS(52.5,",DIC(0)="L",X=RXN K DD,DO D FILE^DICN S DA=+Y
.S ^PS(52.5,DA,0)=DODD,^PS(52.5,DA,"P")=0,LFD=$E($P(^PS(52.5,DA,0),"^",2),4,5)_"-"_$E($P(^(0),"^",2),6,7)_"-"_$E($P(^(0),"^",2),2,3)
.S DIK="^PS(52.5," D IX^DIK K DIK,DA S DA=RXN,$P(^PSRX(DA,"STA"),"^")=STA
.S ACOM="Date of Death Deleted. RX Placed on Suspense until "_LFD
.K ^PSRX("APSOD",PSODFN,DA),^PSRX(DA,"DDSTA")
.I STA=5 S ST="SC",PHST="ZS" D LOG D EN^PSOHLSN1(DA,ST,PHST,ACOM) K ST,PHST,ACOM,LFD
I FILE=52 S ^PSRX(DA,"STA")=STA I STA=3!(STA=16) D Q
.S ^PSRX(DA,"H")=DODD,^PSRX("AH",$P(^PSRX(DA,"H"),"^"),DA)=""
.S ACOM="Date of Death Deleted. Medication Returned to"_$S(STA=16:" Provider",1:"")_" Hold Status "_$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3)_"."
.D LOG,EN^PSOHLSN1(DA,"OH","",ACOM) K ACOM
.K ^PSRX("APSOD",PSODFN,DA),^PSRX(DA,"DDSTA")
S ACOM="Date of Death Deleted. Prescription Reinstated." D EN^PSOHLSN1(DA,"SC","CM",ACOM),LOG K ACOM
Q
LOG K ACNT F SUB=0:0 S SUB=$O(^PSRX(DA,"A",SUB)) Q:'SUB S ACNT=$G(ACNT)+1
S RFCNT=0 F RF=0:0 S RF=$O(^PSRX(DA,1,RF)) Q:'RF S RFCNT=$G(RFCNT)+1 S:RF>5 RFCNT=$G(RFCNT)+1
S ACNT=$G(ACNT)+1
D NOW^%DTC S ^PSRX(DA,"A",0)="^52.3DA^"_ACNT_"^"_ACNT S ^PSRX(DA,"A",ACNT,0)=%_"^R^"_DUZ_"^"_RFCNT_"^"_ACOM
K ^PSRX("APSOD",PSODFN,DA),ACNT,RFCNT,RF,%
S $P(^PSRX(DA,3),"^")=$P(^PSRX(DA,3),"^",5),$P(^(3),"^",2)=$P(^(3),"^",8)
S $P(^PSRX(DA,3),"^",5)="",$P(^(3),"^",8)=""
Q
NVER ;Called from PSOCAN3, needs DA defined
N PSONVC,PSONVCP,PSONVCC
S PSONVC="SC",PSONVCP="IP",PSONVCC="Put in non-verified status" D EN^PSOHLSN1(DA,PSONVC,PSONVCP,PSONVCC)
Q
RMB(IDX) ;remove Rx if found in array BBRX() (Bingo Board)
N ST4,ST5,ST6,K
S ST4=BBRX(IDX) Q:ST4'[(DA_",")
S ST6=""
F K=1:1 S ST5=$P(ST4,",",K) Q:'ST5 D
. S:ST5'=DA ST6=ST6_$S('ST6:"",1:",")_ST5
. S:ST6]"" BBRX(IDX)=ST6_"," K:ST6="" BBRX(IDX)
I '$D(BBRX) K BINGCRT
Q
PSOCAN2 ;BHAM ISC/JMB - modular rx cancel with speed ability drug check ;29-May-2012 14:40;PLS
+1 ;;7.0;OUTPATIENT PHARMACY;**8,18,62,46,88,164,1006,235,148,259,281,287,1015**;DEC 1997;Build 62
+2 ;External reference to ^PSDRUG supported by dbia 221
+3 ; Modified - IHS/MSC/PLS - 04/30/08 - Line HLD+2
REINS NEW DODR
+1 IF $PIECE(^PSRX(DA,2),"^",6)<DT
Begin DoDot:1
+2 SET Y=$PIECE(^PSRX(DA,2),"^",6)
XECUTE ^DD("DD")
+3 WRITE !!,"Rx: "_$PIECE(^PSRX(DA,0),"^")_" Drug: "_$SELECT($DATA(^PSDRUG($PIECE(^PSRX(DA,0),"^",6),0)):$PIECE(^(0),"^"),1:""),!,"Expired "_Y_" and cannot be Reinstated!",!
+4 DO PAUSE^VALM1
End DoDot:1
QUIT
+5 IF $DATA(^PSRX("APSOD",$PIECE(^PSRX(DA,0),"^",2),DA))
SET PSCAN($PIECE(^PSRX(DA,0),"^"))=DA_"^R"
SET DODR=1
DO AUTOD
GOTO ACT
+6 IF $PIECE(PSOPAR,"^",2)
IF '$DATA(^XUSEC("PSORPH",DUZ))
DO VERIFY
Begin DoDot:1
+7 SET RX1=$PIECE(^PSRX(DA,0),"^")
IF '$DATA(PSCAN(RX1))
SET PSCAN(RX1)=DA_"^R"
KILL RX1
End DoDot:1
DO AREC^PSOCAN1
QUIT
ACT WRITE !
FOR I=1:1:80
WRITE "="
+1 DO ^PSOBUILD
SET DRG=+$PIECE(^PSRX(DA,0),"^",6)
SET DRG=$SELECT($DATA(^PSDRUG(DRG,0)):$PIECE(^(0),"^"),1:"")
SET HOLDRX=RX
+2 WRITE !!,RX_" "_DRG
DO DRGDRG
SET RX=HOLDRX
KILL HOLDRX
IF $PIECE(^PSRX(+PSCAN(RX),"STA"),"^")'=12!($GET(PSORX("DFLG")))
QUIT
SET DA=+PSCAN(RX)
SET REA=$PIECE(PSCAN(RX),"^",2)
DO CAN^PSOCAN
WRITE !
+3 NEW RXIEN
SET RXIEN=DA
+4 ;Takes action on reinstated Rx's
+5 SET RFCNT=0
FOR RF=0:0
SET RF=$ORDER(^PSRX(DA,1,RF))
IF 'RF
QUIT
SET RFCNT=RF
+6 SET (LPRT,LREF)=""
FOR LL=0:0
SET LL=$ORDER(^PSRX(DA,"L",LL))
IF 'LL
QUIT
SET LPRT=$PIECE($GET(^PSRX(DA,"L",LL,0)),".")
SET LREF=$PIECE($GET(^(0)),"^",2)
+7 IF 'RFCNT
SET FDT=$SELECT($PIECE($GET(^PSRX(DA,2)),"^",2)'="":$PIECE($GET(^PSRX(DA,2)),"^",2),1:$PIECE($GET(^PSRX(DA,2)),"^"))
SET RELDT=$PIECE(^(2),"^",13)
SET RELDT=$PIECE(RELDT,".")
+8 IF RFCNT
SET FDT=$PIECE($GET(^PSRX(DA,1,RFCNT,0)),"^")
SET RELDT=$PIECE(^(0),"^",18)
SET RELDT=$PIECE(RELDT,".")
+9 SET Y=FDT
DO DD^%DT
SET XFDT=Y
IF RELDT'=""
SET Y=RELDT
DO DD^%DT
SET XRELDT=Y
+10 IF LPRT'=""
SET Y=LPRT
DO DD^%DT
SET XLPDT=Y
+11 ;If Rx was released, do nothing
+12 IF RELDT'=""
WRITE !,RX_" Reinstated -- ",!?3,$SELECT('RFCNT:"Filled",1:"Refilled # "_LREF)_": "_XFDT,?32,"Printed: "_$SELECT(LREF=RFCNT:XLPDT,1:""),?56,"Released: "_$GET(XRELDT)
HANG 3
QUIT
+13 ;If Rx not released, check fill/refill date for action
+14 IF $GET(PSXSYS)
DO REINS^PSOCMOPA
IF $GET(XFLAG)
KILL XFLAG
QUIT
+15 WRITE !,"Prescription #"_RX_" REINSTATED!"
+16 ;
+17 NEW PSOTRIC
SET PSOTRIC=""
SET PSOTRIC=$$TRIC^PSOREJP1(RXIEN,RFCNT,PSOTRIC)
+18 DO SUBMIT^PSOREJU3(RXIEN,RFCNT,PSOTRIC)
+19 ;
+20 WRITE !?3,"Prescription #",RX_": "
+21 WRITE !?6,$SELECT('RFCNT:" Filled",1:" Refilled # "_LREF)_": "_XFDT," Printed: "_$SELECT(LREF=RFCNT:XLPDT,1:"")," Released: "_$GET(XRELDT),!
+22 IF FDT<DT
Begin DoDot:1
+23 ;No label for Rx's with claims rejects
IF $$FIND^PSOREJUT(RXIEN)
QUIT
+24 ;No labels for Tricare non-payable/in progess Rx
IF PSOTRIC&($$STATUS^PSOBPSUT(RXIEN,RFCNT)'["PAYABLE")
QUIT
+25 SET DIR("A")=" ** Do you want to print the label now"
SET DIR("B")="N"
SET DIR(0)="Y"
SET DIR("?")="Enter 'Y' to print the label now. If 'N' is entered, the label may be reprinted through reprint at a later date."
+26 DO ^DIR
KILL DIR
IF $GET(DIRUT)!('Y)
QUIT
SET PPL=RXIEN
DO Q^PSORXL
QUIT
End DoDot:1
+27 IF FDT=DT
Begin DoDot:1
+28 IF $$FIND^PSOREJUT(RXIEN)
QUIT
+29 IF PSOTRIC&($$STATUS^PSOBPSUT(RXIEN,RFCNT)'["PAYABLE")
QUIT
+30 WRITE !?5,"Either print the label using the reprint option "
+31 WRITE !?7,"or check later to see if the label has been printed."
QUIT
End DoDot:1
+32 IF FDT>DT&('$GET(DODR))
WRITE !?5,"Placing Rx on suspense. Please wait..."
DO SUS
+33 KILL DODR
+34 QUIT
SUS ;Adds rec to suspense
+1 SET ACT=1
SET RXN=DA
SET RX0=^PSRX(DA,0)
SET RXS=$ORDER(^PS(52.5,"B",DA,0))
IF RXS
SET DA=RXS
SET DIK="^PS(52.5,"
DO ^DIK
SET DA=RXN
+2 SET RXP=$SELECT($DATA(RXP):RXP,1:0)
SET DIC="^PS(52.5,"
SET DIC(0)="L"
SET X=RXN
SET DIC("DR")=".02///"_FDT_";.03///"_$PIECE(RX0,"^",2)_";.04///M;.05///"_RXP_";.06////"_$GET(PSOSITE)_";2///0"
KILL DD,DO
DO FILE^DICN
+3 IF +$GET(Y)
IF $GET(RFCNT)'=""
SET $PIECE(^PS(52.5,+Y,0),"^",13)=$GET(RFCNT)
+4 SET DA=RXN
SET $PIECE(^PSRX(DA,"STA"),"^")=5
SET LFD=$EXTRACT($PIECE(^PSRX(DA,3),"^"),4,5)_"-"_$EXTRACT($PIECE(^(3),"^"),6,7)_"-"_$EXTRACT($PIECE(^(3),"^"),2,3)
+5 SET ACOM="RX Placed on Suspense until "_LFD
DO AREC^PSOCAN1
SET ST="SC"
SET PHST="ZS"
DO EN^PSOHLSN1(DA,ST,PHST,ACOM)
KILL ST,PHST
+6 QUIT
DRGDRG ;Checks for drug/drug interaction, duplicate drug and class
+1 IF $PIECE(^PSRX(DA,2),"^",6)<DT
QUIT
+2 SET STA="ACTIVE^NON-VERIFIED^R^HOLD^NON-VERIFIED^ACTIVE^^^^^^ACTIVE^DISCONTINUED^^DISCONTINUED^DISCONTINUED^HOLD"
+3 SET STAT=$PIECE(STA,"^",$PIECE(^PSRX(DA,"STA"),"^")+1)
+4 SET X=$PIECE(^PSRX(DA,0),"^",6)
SET DIC="^PSDRUG("
SET DIC(0)="MZO"
DO ^DIC
KILL DIC
IF $DATA(DTOUT)!(Y<0)
QUIT
+5 KILL HOLD
SET NAME=$PIECE(Y(0),"^")
IF +$GET(PSOSD(STAT,NAME))=+PSCAN(RX)
SET HOLD(STAT,NAME)=$GET(PSOSD(STAT,NAME))
KILL PSOSD(STAT,NAME)
+6 IF $GET(PSONEW("OLD VAL"))=+Y
SET PSODRG("QFLG")=1
+7 KILL PSOY
SET PSOY=Y
SET PSOY(0)=Y(0)
+8 SET PSORENW("OIRXN")=DA
DO SET^PSODRG
DO POST^PSODRG
SET REA=$PIECE(PSCAN($PIECE(^PSRX(PSORENW("OIRXN"),0),"^")),"^",2)
+9 WRITE !
IF $GET(HOLD(STAT,NAME))]""
SET PSOSD(STAT,NAME)=$GET(HOLD(STAT,NAME))
KILL HOLD,STA,STAT,PSORENW("OIRXN")
+10 QUIT
VERIFY ;Put in non-verify file
+1 SET PSRXDA=DA
SET DIC="^PS(52.4,"
SET DLAYGO=52.4
SET (X,DINUM)=PSRXDA
SET DIC(0)="ML"
SET DIC("DR")="1////"_PSODFN_";2////"_DUZ_";4////"_DT
+2 KILL DD,DO
DO FILE^DICN
KILL DIC,DLAYGO,DINUM
+3 SET DA=PSRXDA
SET $PIECE(^PSRX(DA,"STA"),"^")=1
+4 SET ST="SC"
SET PHST="IP"
SET VCOM="Put in non-verified status"
DO EN^PSOHLSN1(DA,ST,PHST,VCOM)
KILL ST,PHST,VCOM
+5 QUIT
HLD NEW PSDTEST,PDA,CMOP,SUSD
IF $PIECE(^PSRX(DA,"STA"),"^")=3
Begin DoDot:1
+1 SET ACOM=$SELECT(REA="C":"Discontinued",1:"Reinstated")_" while on hold during Rx cancel. "
IF $PIECE(^PSRX(DA,"H"),"^")
KILL ^PSRX("AH",$PIECE(^PSRX(DA,"H"),"^"),DA)
SET ^PSRX(DA,"H")=""
+2 ;IHS/MSC/PLS - 04/30/08 - Next line removed to prevent Fill Date from being set.
+3 ;I $P(^PSRX(DA,0),"^",13),'$O(^PSRX(DA,1,0)) S DIE=52,DR="22///"_$E($P(^PSRX(DA,0),"^",13),1,7) D ^DIE K DIE,DR Q
+4 IF $PIECE(^PSRX(DA,0),"^",13)
IF '$ORDER(^PSRX(DA,1,0))
QUIT
+5 SET (IFN,SUSD)=0
FOR
SET IFN=$ORDER(^PSRX(DA,1,IFN))
IF 'IFN
QUIT
SET SUSD=IFN
SET RFDT=$PIECE(^PSRX(DA,1,IFN,0),"^")
+6 IF '$GET(SUSD)
QUIT
IF '$PIECE(^PSRX(DA,1,SUSD,0),"^",18)
SET PSDTEST=0
Begin DoDot:2
+7 FOR PDA=0:0
SET PDA=$ORDER(^PSRX(DA,"L",PDA))
IF 'PDA
QUIT
IF $PIECE($GET(^PSRX(DA,"L",PDA,0)),"^",2)=SUSD
SET PSDTEST=1
+8 KILL CMOP
DO ^PSOCMOPA
IF $GET(CMOP(CMOP("L")))=""
IF $GET(CMOP("S"))'="L"
QUIT
+9 SET PSDTEST=1
End DoDot:2
IF 'PSDTEST
KILL ^PSRX(DA,1,SUSD),^PSRX("AD",RFDT,DA,SUSD),^PSRX(DA,1,"B",RFDT,SUSD),IFN,SUSD,RFDT
End DoDot:1
+10 QUIT
REF SET IFN=0
FOR
SET IFN=$ORDER(^PSRX(DA,1,IFN))
IF 'IFN
QUIT
IF $PIECE($GET(^PSRX(DA,1,IFN,0)),"^")=SUSD
IF '$PIECE(^(0),"^",18)
Begin DoDot:1
+1 DO DELREF
IF $GET(PSORFDEL)
KILL PSORFDEL
QUIT
+2 ;PSO*7*259;CHECK IF REFILL RELEASED OR LABEL PRINTED
+3 ;REFILL RELEASED
IF $PIECE($GET(^PSRX(DA,1,IFN,0)),"^",18)]""
QUIT
+4 NEW PSONODEL,PSOLBL
SET PSONODEL=0
+5 IF $PIECE(^PSRX(DA,"STA"),"^")=5
DO REF^PSOCAN4
IF PSONODEL
QUIT
+6 SET PSOLBL=""
FOR
SET PSOLBL=$ORDER(^PSRX(DA,"L",PSOLBL),-1)
IF 'PSOLBL
QUIT
IF PSONODEL
QUIT
IF $PIECE(^PSRX(DA,"L",PSOLBL,0),"^",2)<IFN
QUIT
IF $PIECE(^PSRX(DA,"L",PSOLBL,0),"^",2)=IFN
SET PSONODEL=1
+7 IF PSONODEL
QUIT
+8 KILL PSORFDEL
KILL ^PSRX(DA,1,IFN),^PSRX("AD",SUSD,DA,IFN),^PSRX(DA,1,"B",SUSD,IFN)
+9 SET $PIECE(^PSRX(DA,1,0),"^",4)=$PIECE(^PSRX(DA,1,0),"^",4)-1
SET DA(1)=DA
+10 SET NODE=0
DO SPR^PSOUTL
KILL DA(1),RF,NODE
End DoDot:1
+11 SET IFN=0
FOR
SET IFN=$ORDER(^PSRX(DA,1,IFN))
IF 'IFN
QUIT
IF '$ORDER(^PSRX(DA,1,IFN))
SET $PIECE(^PSRX(DA,3),"^")=+$PIECE(^PSRX(DA,1,IFN,0),"^")
SET $PIECE(^(3),"^",2)=SUSD
+12 IF '$ORDER(^PSRX(DA,1,0))
SET $PIECE(^PSRX(DA,3),"^")=$PIECE(^PSRX(DA,2),"^",2)
SET $PIECE(^PSRX(DA,3),"^",2)=SUSD
+13 KILL IFN,SUSD
+14 QUIT
KILL KILL %,ACNT,ACOM,ACT,ALL,BCNUM,CMOP,CNT,DA,DAYS360,DEAD,DRG,DIRUT,DR,DRUG,DTOUT,DUOUT,FDT,HOLD,I,II,IN,IT,JJ,LC,LFD,LINE,LL,LPRT,LREF,LSI,NAME,NDF,NOEXP,NSF,OUT,RXSP,EN,WARN
IF '$GET(POERR)
KILL INCOM
+1 KILL PSODRUG,PCNT,POP,PPL,PS,PSFROM,PSINV,PLINE,PSI,PSINV,PSOCAN,PSOCMOP,PSODFN,PSODRG,PSOOPT,PSOSD,PSPOP,PSRXDA,PSS,PSVC,PSONOOR
+2 KILL REA,RELDT,RF,RFDATE,RFCNT,RFL,RFL1,RFLL,RP,RX,RX0,RXCNT,RXDA,RXN,RXNUM,RXP,RXREC,RXREF,RXS,SDATE,SPCANC,SS,STAT,SUB,X,XFDT,XLPDT,XRELDT,Y
DO KVA^VADPT
QUIT
DELREF ;
+1 NEW RDL,PSCNODE
+2 SET PSORFDEL=0
+3 FOR RDL=0:0
SET RDL=$ORDER(^PSRX(DA,4,RDL))
IF 'RDL
QUIT
IF $GET(IFN)=$PIECE($GET(^PSRX(DA,4,RDL,0)),"^",3)
SET PSCNODE=$GET(^(0))
+4 IF $GET(PSCNODE)=""
QUIT
+5 IF +$PIECE(PSCNODE,"^",4)<3
SET PSORFDEL=1
+6 QUIT
AUTOD ;reinstates Rxs dc'd by date of death
+1 IF $GET(^PSRX(DA,"DDSTA"))']""
KILL ^PSRX("APSOD",+$PIECE(^PSRX(DA,0),"^",2),DA),DODR
QUIT
+2 SET DODS=$PIECE(^PSRX(DA,"DDSTA"),"^")
SET DODD=$PIECE(^("DDSTA"),"^",2,245)
+3 SET FILE=$PIECE(DODS,";")
SET STA=$PIECE(DODS,";",2)
+4 IF FILE=52.4
Begin DoDot:1
+5 SET RXN=DA
SET ^PS(52.4,DA,0)=DODD
SET DIK="^PS(52.4,"
DO IX^DIK
KILL DIK,DA
SET DA=RXN
SET $PIECE(^PSRX(DA,"STA"),"^")=STA
+6 SET ST="SC"
SET PHST="IP"
SET ACOM="Date of Death Deleted. Returned to Non-Verified status."
+7 KILL ^PSRX("APSOD",$PIECE(^PSRX(DA,0),"^",2),DA),^PSRX(DA,"DDSTA")
+8 SET DA=RXN
DO LOG
DO EN^PSOHLSN1(DA,ST,PHST,ACOM)
KILL ST,PHST,ACOM,RXN
End DoDot:1
QUIT
+9 IF FILE=52.5
Begin DoDot:1
+10 ;Adds rec to suspense
+11 SET RXN=DA
SET RXS=$ORDER(^PS(52.5,"B",DA,0))
IF RXS
SET DA=RXS
SET DIK="^PS(52.5,"
DO ^DIK
+12 SET DIC="^PS(52.5,"
SET DIC(0)="L"
SET X=RXN
KILL DD,DO
DO FILE^DICN
SET DA=+Y
+13 SET ^PS(52.5,DA,0)=DODD
SET ^PS(52.5,DA,"P")=0
SET LFD=$EXTRACT($PIECE(^PS(52.5,DA,0),"^",2),4,5)_"-"_$EXTRACT($PIECE(^(0),"^",2),6,7)_"-"_$EXTRACT($PIECE(^(0),"^",2),2,3)
+14 SET DIK="^PS(52.5,"
DO IX^DIK
KILL DIK,DA
SET DA=RXN
SET $PIECE(^PSRX(DA,"STA"),"^")=STA
+15 SET ACOM="Date of Death Deleted. RX Placed on Suspense until "_LFD
+16 KILL ^PSRX("APSOD",PSODFN,DA),^PSRX(DA,"DDSTA")
+17 IF STA=5
SET ST="SC"
SET PHST="ZS"
DO LOG
DO EN^PSOHLSN1(DA,ST,PHST,ACOM)
KILL ST,PHST,ACOM,LFD
End DoDot:1
QUIT
+18 IF FILE=52
SET ^PSRX(DA,"STA")=STA
IF STA=3!(STA=16)
Begin DoDot:1
+19 SET ^PSRX(DA,"H")=DODD
SET ^PSRX("AH",$PIECE(^PSRX(DA,"H"),"^"),DA)=""
+20 SET ACOM="Date of Death Deleted. Medication Returned to"_$SELECT(STA=16:" Provider",1:"")_" Hold Status "_$EXTRACT(DT,4,5)_"/"_$EXTRACT(DT,6,7)_"/"_$EXTRACT(DT,2,3)_"."
+21 DO LOG
DO EN^PSOHLSN1(DA,"OH","",ACOM)
KILL ACOM
+22 KILL ^PSRX("APSOD",PSODFN,DA),^PSRX(DA,"DDSTA")
End DoDot:1
QUIT
+23 SET ACOM="Date of Death Deleted. Prescription Reinstated."
DO EN^PSOHLSN1(DA,"SC","CM",ACOM)
DO LOG
KILL ACOM
+24 QUIT
LOG KILL ACNT
FOR SUB=0:0
SET SUB=$ORDER(^PSRX(DA,"A",SUB))
IF 'SUB
QUIT
SET ACNT=$GET(ACNT)+1
+1 SET RFCNT=0
FOR RF=0:0
SET RF=$ORDER(^PSRX(DA,1,RF))
IF 'RF
QUIT
SET RFCNT=$GET(RFCNT)+1
IF RF>5
SET RFCNT=$GET(RFCNT)+1
+2 SET ACNT=$GET(ACNT)+1
+3 DO NOW^%DTC
SET ^PSRX(DA,"A",0)="^52.3DA^"_ACNT_"^"_ACNT
SET ^PSRX(DA,"A",ACNT,0)=%_"^R^"_DUZ_"^"_RFCNT_"^"_ACOM
+4 KILL ^PSRX("APSOD",PSODFN,DA),ACNT,RFCNT,RF,%
+5 SET $PIECE(^PSRX(DA,3),"^")=$PIECE(^PSRX(DA,3),"^",5)
SET $PIECE(^(3),"^",2)=$PIECE(^(3),"^",8)
+6 SET $PIECE(^PSRX(DA,3),"^",5)=""
SET $PIECE(^(3),"^",8)=""
+7 QUIT
NVER ;Called from PSOCAN3, needs DA defined
+1 NEW PSONVC,PSONVCP,PSONVCC
+2 SET PSONVC="SC"
SET PSONVCP="IP"
SET PSONVCC="Put in non-verified status"
DO EN^PSOHLSN1(DA,PSONVC,PSONVCP,PSONVCC)
+3 QUIT
RMB(IDX) ;remove Rx if found in array BBRX() (Bingo Board)
+1 NEW ST4,ST5,ST6,K
+2 SET ST4=BBRX(IDX)
IF ST4'[(DA_",")
QUIT
+3 SET ST6=""
+4 FOR K=1:1
SET ST5=$PIECE(ST4,",",K)
IF 'ST5
QUIT
Begin DoDot:1
+5 IF ST5'=DA
SET ST6=ST6_$SELECT('ST6:"",1:",")_ST5
+6 IF ST6]""
SET BBRX(IDX)=ST6_","
IF ST6=""
KILL BBRX(IDX)
End DoDot:1
+7 IF '$DATA(BBRX)
KILL BINGCRT
+8 QUIT
