- PSOCAN2 ;BHAM ISC/JMB - rx cancel with speed ability drug check ; 2/16/12 3:40pm
- ;;7.0;OUTPATIENT PHARMACY;**8,18,62,46,88,164,235,148,259,281,287,251,375,379,396,390,372,416,411**;DEC 1997;Build 95
- ;External reference to ^PSDRUG supported by DBIA 221
- REINS N DODR,ORN,PSOREINO S PSOREINO=1
- I $G(PSODFN)'=$G(PSOODOSP) K PSORX("DOSING OFF"),PSOREINF S PSOODOSP=PSODFN
- 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)) N PSOVODA S PSOVODA=DA D DRGDRG Q:$G(PSOQUIT)&($G(PSOREINS)) S DA=PSOVODA Q:PSORX("DFLG") 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 I $G(POERR) S HPOERR=POERR
- D DRGDRG Q:$G(PSOQUIT)&($G(PSOREINS))
- S:$G(HPOERR) POERR=HPOERR S:$G(PSORX("DFLG"))'=1 PSORX("DFLG")=0
- S RX=HOLDRX K HOLDRX,HPOERR 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,XRELDT,XFDT)="" 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 unresolved claims rejects
- .Q:PSOTRIC&($$STATUS^PSOBPSUT(RXIEN,RFCNT)["IN PROGRESS") ;No labels for TRICARE/CHAMPVA in progress Rx *396
- .I PSOTRIC,$P($G(^PSRX(RXIEN,"STA")),"^")=12 Q ;No label for TRICARE/CHAMPVA if discontinued via Reject Notification screen *396
- .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) ;No label for Rx's with unresolved claims rejects
- . Q:PSOTRIC&($$STATUS^PSOBPSUT(RXIEN,RFCNT)["IN PROGRESS") ;No labels for TRICARE/CHAMPVA in progress Rx *396
- . I PSOTRIC,$P($G(^PSRX(RXIEN,"STA")),"^")=12 Q ;No label for TRICARE/CHAMPVA if discontinued via Reject Notification screen *396
- . W !?5,"Either print the label using the reprint option "
- . W !?7,"or check later to see if the label has been printed." D WAIT^PSODRG 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 (PSORX("DFLG"),PSORXED("DFLG"))=0
- 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,PSOTECCK S PSOY=Y,PSOY(0)=Y(0)
- I '$D(^XUSEC("PSORPH",DUZ)) S PSOTECCK=1 N ZRXN
- S (ZRXN,PSORENW("OIRXN"))=DA D SET^PSODRG,POST^PSODRG Q:$G(PSOREINS)&$G(PSOQUIT)
- D:'$G(PSORX("DFLG")) DOSCK^PSODOSUT("C")
- 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")
- ;saves drug allergy order chks pso*7*390
- ;I +$G(^TMP("PSODAOC",$J,1,0)) D
- I $D(^TMP("PSODAOC",$J)) D
- .N RXN,PSODAOC S RXN=ZRXN,PSODAOC="Rx Reinstate Order Acceptance_OP"
- .D DAOC^PSONEW
- .K ^TMP("PSODAOC",$J),RET
- 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")=""
- .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
- .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
- K ^PSRX("APSOD",PSODFN,DA),^PSRX(DA,"DDSTA")
- 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,%
- I $P(^PSRX(DA,3),"^",10) S $P(^PSRX(DA,3),"^")=$P(^PSRX(DA,3),"^",10) ;*396
- S $P(^PSRX(DA,3),"^",2)=$P(^PSRX(DA,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
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOCAN2 11058 printed Jan 18, 2025@03:26:22 Page 2
- PSOCAN2 ;BHAM ISC/JMB - rx cancel with speed ability drug check ; 2/16/12 3:40pm
- +1 ;;7.0;OUTPATIENT PHARMACY;**8,18,62,46,88,164,235,148,259,281,287,251,375,379,396,390,372,416,411**;DEC 1997;Build 95
- +2 ;External reference to ^PSDRUG supported by DBIA 221
- REINS NEW DODR,ORN,PSOREINO
- SET PSOREINO=1
- +1 IF $GET(PSODFN)'=$GET(PSOODOSP)
- KILL PSORX("DOSING OFF"),PSOREINF
- SET PSOODOSP=PSODFN
- +2 IF $PIECE(^PSRX(DA,2),"^",6)<DT
- Begin DoDot:1
- +3 SET Y=$PIECE(^PSRX(DA,2),"^",6)
- XECUTE ^DD("DD")
- +4 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!",!
- +5 DO PAUSE^VALM1
- End DoDot:1
- QUIT
- +6 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
- +7 IF $PIECE(PSOPAR,"^",2)
- IF '$DATA(^XUSEC("PSORPH",DUZ))
- NEW PSOVODA
- SET PSOVODA=DA
- DO DRGDRG
- if $GET(PSOQUIT)&($GET(PSOREINS))
- QUIT
- SET DA=PSOVODA
- if PSORX("DFLG")
- QUIT
- DO VERIFY
- Begin DoDot:1
- +8 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
- IF $GET(POERR)
- SET HPOERR=POERR
- +3 DO DRGDRG
- if $GET(PSOQUIT)&($GET(PSOREINS))
- QUIT
- +4 if $GET(HPOERR)
- SET POERR=HPOERR
- if $GET(PSORX("DFLG"))'=1
- SET PSORX("DFLG")=0
- +5 SET RX=HOLDRX
- KILL HOLDRX,HPOERR
- if $PIECE(^PSRX(+PSCAN(RX),"STA"),"^")'=12!($GET(PSORX("DFLG")))
- QUIT
- +6 SET DA=+PSCAN(RX)
- SET REA=$PIECE(PSCAN(RX),"^",2)
- DO CAN^PSOCAN
- WRITE !
- +7 NEW RXIEN
- SET RXIEN=DA
- +8 ;Takes action on reinstated Rx's
- +9 SET RFCNT=0
- FOR RF=0:0
- SET RF=$ORDER(^PSRX(DA,1,RF))
- if 'RF
- QUIT
- SET RFCNT=RF
- +10 SET (LPRT,LREF,XRELDT,XFDT)=""
- 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)
- +11 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,".")
- +12 IF RFCNT
- SET FDT=$PIECE($GET(^PSRX(DA,1,RFCNT,0)),"^")
- SET RELDT=$PIECE(^(0),"^",18)
- SET RELDT=$PIECE(RELDT,".")
- +13 SET Y=FDT
- DO DD^%DT
- SET XFDT=Y
- IF RELDT'=""
- SET Y=RELDT
- DO DD^%DT
- SET XRELDT=Y
- +14 IF LPRT'=""
- SET Y=LPRT
- DO DD^%DT
- SET XLPDT=Y
- +15 ;If Rx was released, do nothing
- +16 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
- +17 ;If Rx not released, check fill/refill date for action
- +18 IF $GET(PSXSYS)
- DO REINS^PSOCMOPA
- IF $GET(XFLAG)
- KILL XFLAG
- QUIT
- +19 WRITE !,"Prescription #"_RX_" REINSTATED!"
- +20 ;
- +21 NEW PSOTRIC
- SET PSOTRIC=""
- SET PSOTRIC=$$TRIC^PSOREJP1(RXIEN,RFCNT,PSOTRIC)
- +22 DO SUBMIT^PSOREJU3(RXIEN,RFCNT,PSOTRIC)
- +23 ;
- +24 WRITE !?3,"Prescription #",RX_": "
- +25 WRITE !?6,$SELECT('RFCNT:" Filled",1:" Refilled # "_LREF)_": "_XFDT," Printed: "_$SELECT(LREF=RFCNT:XLPDT,1:"")," Released: "_$GET(XRELDT),!
- +26 IF FDT<DT
- Begin DoDot:1
- +27 ;No label for Rx's with unresolved claims rejects
- if $$FIND^PSOREJUT(RXIEN)
- QUIT
- +28 ;No labels for TRICARE/CHAMPVA in progress Rx *396
- if PSOTRIC&($$STATUS^PSOBPSUT(RXIEN,RFCNT)["IN PROGRESS")
- QUIT
- +29 ;No label for TRICARE/CHAMPVA if discontinued via Reject Notification screen *396
- IF PSOTRIC
- IF $PIECE($GET(^PSRX(RXIEN,"STA")),"^")=12
- QUIT
- +30 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."
- +31 DO ^DIR
- KILL DIR
- if $GET(DIRUT)!('Y)
- QUIT
- SET PPL=RXIEN
- DO Q^PSORXL
- QUIT
- End DoDot:1
- +32 IF FDT=DT
- Begin DoDot:1
- +33 ;No label for Rx's with unresolved claims rejects
- if $$FIND^PSOREJUT(RXIEN)
- QUIT
- +34 ;No labels for TRICARE/CHAMPVA in progress Rx *396
- if PSOTRIC&($$STATUS^PSOBPSUT(RXIEN,RFCNT)["IN PROGRESS")
- QUIT
- +35 ;No label for TRICARE/CHAMPVA if discontinued via Reject Notification screen *396
- IF PSOTRIC
- IF $PIECE($GET(^PSRX(RXIEN,"STA")),"^")=12
- QUIT
- +36 WRITE !?5,"Either print the label using the reprint option "
- +37 WRITE !?7,"or check later to see if the label has been printed."
- DO WAIT^PSODRG
- QUIT
- End DoDot:1
- +38 IF FDT>DT&('$GET(DODR))
- WRITE !?5,"Placing Rx on suspense. Please wait..."
- DO SUS
- +39 KILL DODR
- +40 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 (PSORX("DFLG"),PSORXED("DFLG"))=0
- +3 SET STA="ACTIVE^NON-VERIFIED^R^HOLD^NON-VERIFIED^ACTIVE^^^^^^ACTIVE^DISCONTINUED^^DISCONTINUED^DISCONTINUED^HOLD"
- +4 SET STAT=$PIECE(STA,"^",$PIECE(^PSRX(DA,"STA"),"^")+1)
- +5 SET X=$PIECE(^PSRX(DA,0),"^",6)
- SET DIC="^PSDRUG("
- SET DIC(0)="MZO"
- DO ^DIC
- KILL DIC
- if $DATA(DTOUT)!(Y<0)
- QUIT
- +6 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)
- +7 if $GET(PSONEW("OLD VAL"))=+Y
- SET PSODRG("QFLG")=1
- +8 KILL PSOY,PSOTECCK
- SET PSOY=Y
- SET PSOY(0)=Y(0)
- +9 IF '$DATA(^XUSEC("PSORPH",DUZ))
- SET PSOTECCK=1
- NEW ZRXN
- +10 SET (ZRXN,PSORENW("OIRXN"))=DA
- DO SET^PSODRG
- DO POST^PSODRG
- if $GET(PSOREINS)&$GET(PSOQUIT)
- QUIT
- +11 if '$GET(PSORX("DFLG"))
- DO DOSCK^PSODOSUT("C")
- +12 SET REA=$PIECE(PSCAN($PIECE(^PSRX(PSORENW("OIRXN"),0),"^")),"^",2)
- +13 WRITE !
- if $GET(HOLD(STAT,NAME))]""
- SET PSOSD(STAT,NAME)=$GET(HOLD(STAT,NAME))
- KILL HOLD,STA,STAT,PSORENW("OIRXN")
- +14 ;saves drug allergy order chks pso*7*390
- +15 ;I +$G(^TMP("PSODAOC",$J,1,0)) D
- +16 IF $DATA(^TMP("PSODAOC",$JOB))
- Begin DoDot:1
- +17 NEW RXN,PSODAOC
- SET RXN=ZRXN
- SET PSODAOC="Rx Reinstate Order Acceptance_OP"
- +18 DO DAOC^PSONEW
- +19 KILL ^TMP("PSODAOC",$JOB),RET
- End DoDot:1
- +20 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 IF $PIECE(^PSRX(DA,0),"^",13)
- IF '$ORDER(^PSRX(DA,1,0))
- SET DIE=52
- SET DR="22///"_$EXTRACT($PIECE(^PSRX(DA,0),"^",13),1,7)
- DO ^DIE
- KILL DIE,DR
- QUIT
- +3 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),"^")
- +4 if '$GET(SUSD)
- QUIT
- IF '$PIECE(^PSRX(DA,1,SUSD,0),"^",18)
- SET PSDTEST=0
- Begin DoDot:2
- +5 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
- +6 KILL CMOP
- DO ^PSOCMOPA
- IF $GET(CMOP(CMOP("L")))=""
- IF $GET(CMOP("S"))'="L"
- QUIT
- +7 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
- +8 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 KILL ^PSRX("APSOD",PSODFN,DA),^PSRX(DA,"DDSTA")
- +25 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 ;*396
- IF $PIECE(^PSRX(DA,3),"^",10)
- SET $PIECE(^PSRX(DA,3),"^")=$PIECE(^PSRX(DA,3),"^",10)
- +6 SET $PIECE(^PSRX(DA,3),"^",2)=$PIECE(^PSRX(DA,3),"^",8)
- +7 SET $PIECE(^PSRX(DA,3),"^",5)=""
- SET $PIECE(^(3),"^",8)=""
- +8 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
- +9 ;