PSOSUPAT ;BIR/RTR - Pull all Rx's from suspense for a patient ;03/01/96
;;7.0;OUTPATIENT PHARMACY;**8,130,185,427,544,562**;DEC 1997;Build 19
;External reference to ^PS(55 supported by DBIA 2228
;External reference to ^PSSLOCK supported by DBIA 2789
PAT N PSOALRX,PSOALRXS,PSOSKIP
S POP=0 K RXP,RXRR,RXFL,RXRP,RXPR,ASKED,BC,DELCNT,WARN,PSOAL,PSOPROFL,PSOQFLAG,PSOPULL,PSOWIN,PSOWINEN,PPLHOLD,PPLHOLDX
W ! S DIR("A")="Are you entering the patient name or barcode",DIR(0)="SBO^P:Patient Name;B:Barcode"
S DIR("?")="Enter P if you are going to enter the patient name. Enter B if you are going to enter or wand the barcode."
D ^DIR K DIR G:$D(DIRUT) ^PSOSUPRX S BC=Y D NOW^%DTC S TM=$E(%,1,12),TM1=$P(TM,".",2)
BC S (OUT,POP)=0 I BC="B" W ! S DIR("A")="Enter/wand barcode",DIR(0)="FO^5:20",DIR("?")="Enter or wand a prescription barcode for the patient you wish to pull all Rx's for" D ^DIR K DIR G:$G(DIRUT) PAT S BCNUM=Y D
.D PSOINST Q:OUT S RX=$P(BCNUM,"-",2) D:$D(^PSRX(RX,0))
..S (DFN,PSODFN)=$P(^PSRX(RX,0),"^",2) W " ",$P($G(^DPT(DFN,0)),"^")
..D ICN^PSODPT(DFN)
.I '$D(^PSRX(RX,0)) W !,$C(7),"NO PRESCRIPTION RECORD FOR THIS BARCODE." S OUT=1
G:OUT BC
NAM I BC="P" W ! S DIC(0)="AEMZQ",DIC="^DPT(",DIC("S")="I $D(^PS(52.5,""AC"",+Y))!($D(^PS(52.5,""AG"",+Y)))" D ^DIC K DIC G:$D(DTOUT)!($D(DUOUT))!(Y<0) PAT S (DFN,PSODFN)=+Y
S PSOLOUD=1 D:$P($G(^PS(55,PSODFN,0)),"^",6)'=2 EN^PSOHLUP(PSODFN) K PSOLOUD
;
; PSO*7*427 - DMB - 7/24/2015 - Remove call to QUES^PSOSUPRX so that a ECME reject would not cause the entire process to abort. TEST/BEG still checks
; for valid data, labels already printed, and locks but does not build PPLHOLD/arrays nor does it call QUES^PSOSPRX. If there still valid Rx's
; to process, then ask Routing, Pickup Method and whether to Pull the Rx's. After that, we call ECME (but only quit for each
; RX if it fails), then add to PPLHOLD/arrays, and update the Routing/Pickup Method for RX SUSPENSE and the RX.
S (ASKED,DELCNT,WARN)=0
F CBD=0:0 S CBD=$O(^PS(55,DFN,"P",CBD)) Q:CBD'>0 D TEST
I $G(PSOQFLAG) G EXIT
;
; After the TEST/BEG checks, check if there are any prescription left to process
I '$D(PSOALRXS) W !!,"There are no prescriptions left to process - exiting!" D PAUSE G EXIT
;
; Get Routing
W !
K DIR,DTOUT S DIR("A")="Select routing for Rx(s)",DIR(0)="S^M:MAIL;W:WINDOW",DIR("B")="WINDOW" D ^DIR S MW=Y
I Y["^"!($D(DTOUT)) W !!,"Nothing pulled from suspense!" D PAUSE G EXIT
I MW="W" S SUSROUTE=1
;
; If Routing is Window and site paramter to ask Method of Pickup, then get Method of Pickup
I MW="W",$P(PSOPAR,"^",12) K DIR,DTOUT,DUOUT S DIR(0)="52,35" D ^DIR S PSOWIN=1,PSOWINEN=Y I $G(DTOUT)!$G(DUOUT) W !!,"Nothing pulled from suspense!" D PAUSE G EXIT
;
; Ask to Pull Rx's
W !!
K DIR
S DIR("A")="Pull Rx(s) and delete from suspense",DIR("B")="Y",DIR(0)="Y"
S DIR("?",1)="Enter Yes to pull selected Rx(s) from suspense. Since Rx(s) pulled early from",DIR("?",2)="suspense are not associated with a printed batch, these Rx(s) cannot be"
S DIR("?",3)="reprinted from suspense using the 'Reprint batches from Suspense' option.",DIR("?")="Therefore, any Rx(s) pulled early from suspense will be deleted from suspense."
D ^DIR
I Y'=1 W $C(7),!!,"Nothing pulled from suspense!" D PAUSE G EXIT
;
; Loop through the remaining Rx and process
S RXREC="" F S RXREC=$O(PSOALRXS(RXREC)) Q:RXREC="" D
. ; Resubmit to ECME if needed and check results
. N RFL S RFL=$P(PSOALRXS(RXREC),U,1) I RFL="" S RFL=$$LSTRFL^PSOBPSU1(RXREC)
. ;
. ; Do not send a claim if the last submission was rejected and
. ; all rejects have been closed.
. ;
. S PSOSKIP=0
. I $$SEND^PSOBPSU2(RXREC,RFL) D I PSOSKIP Q
. . D ECMESND^PSOBPSU1(RXREC,RFL,,"PE")
. . I $$PSOET^PSOREJP3(RXREC,RFL) S PSOSKIP=1 Q ; Quit if there is an unresolved TRICARE/CHAMPVA non-billable reject code
. . N PSOTRIC S PSOTRIC=$$TRIC^PSOREJP1(RXREC,RFL)
. . I $$FIND^PSOREJUT(RXREC,RFL),$$HDLG^PSOREJU1(RXREC,RFL,"79,88,943","PE","IOQ","I")="Q" S PSOSKIP=1 Q
. . I $P($G(^PSRX(RXREC,"STA")),"^")=12 S PSOSKIP=1 Q ;No label if discontinued via Reject Notification screen
. . Q
. ;
. ; Put on queue to be printed
. S SFN=$P(PSOALRXS(RXREC),U,2)
. S DA=$P(^PS(52.5,SFN,0),"^"),RXPR(DA)=+$P(^(0),"^",5),RXFL(DA)=$P($G(^(0)),"^",13)
. I $L($G(PPLHOLD))<240 S PPLHOLD=$S($G(PPLHOLD)="":$P(^PS(52.5,SFN,0),"^"),1:$G(PPLHOLD)_","_+^PS(52.5,SFN,0)) S:$P(^PS(52.5,SFN,0),"^",12) RXRP(DA)=1
. I $L($G(PPLHOLD))'<240 S PPLHOLDX=$S($G(PPLHOLDX)="":$P(^PS(52.5,SFN,0),"^"),1:$G(PPLHOLDX)_","_+^PS(52.5,SFN,0)) S:$G(RXPR(DA)) RXPR1(DA)=DA_"^"_RXPR(DA) S:$P(^PS(52.5,SFN,0),"^",12) RXRP1(DA)=1 K RXPR(DA)
. I '$D(^PSRX(RXREC,1)),'$G(RXPR(RXREC)),'$G(RXPR1(RXREC)) S PSOPROFL=1
. ;
. ; Save off old Routing/Method of Pickup values
. S PSOGET="M" D GETMW^PSOSUPOE
. S RXRR(RXREC)=$S($P(^PS(52.5,SFN,0),"^",4)="W":"W",1:"M")_"^"_$P($G(^PSRX(RXREC,"MP")),"^")_"^"_$G(PSOGETF)_"^"_$G(PSOGETFN)_"^"_$S($G(PSOGET)="W":"W",1:"M")
. ;
. ; Update Routing and Method of Pickup
. S $P(^PS(52.5,SFN,0),"^",4)=MW
. D MAIL
;
;S HOLDPROF=$G(PSOPROFL) K PSOPROFL
;I $D(PSOPART) S (PSOPULL,PSODBQ)=1 F RR=0:0 S RR=$O(PSOPART(RR)) Q:'RR S PDUZ=DUZ,PPL=RR,RXP=PSOPART(RR) D Q^PSORXL
;S PSOPROFL=HOLDPROF I $D(ZTSK),'$G(PPLHOLD) W !!,"LABEL(S) ARE QUEUED TO PRINT",!
F GGGG=0:0 S GGGG=$O(RXPR(GGGG)) Q:'GGGG K:'$G(RXPR(GGGG)) RXPR(GGGG)
K RXP,PPL S PDUZ=DUZ,PSONOPRT=1
I $G(PPLHOLD)'="" S PPL=PPLHOLD S:$G(SUSROUTE) BBRX(1)=PPL S HOLDPPL=PPL,PSOPULL=1,PSODBQ=1,RXLTOP=1 D WIND^PSOSUPRX D Q^PSORXL I '$G(PSOQFLAG) W !!,"LABEL(S) ARE QUEUED TO PRINT",! S PPL=$P(HOLDPPL,",") D PRF D:'$G(PSOQFLAG) S PSOQFLAG=0
.I $P(PSOPAR,"^",8),$G(PSOPROFL) W !!,"PROFILE(S) ARE QUEUED TO PRINT"
;call to bingo board
I $G(PPLHOLDX),'$G(PSOQGLAG),$G(SUSROUTE) S BBRX(2)=PPLHOLDX
D:$G(BINGRTE)&($D(DISGROUP))&('$G(PSOQFLAG)) ^PSOBING1 K BINGRTE,BBRX
I $G(PPLHOLDX),'$G(PSOQFLAG) D S PDUZ=DUZ,PPL=PPLHOLDX,PSNP=0,(PSODBQ,PSOPULL)=1 D Q^PSORXL
.F XXX=0:0 S XXX=$O(RXPR1(XXX)) Q:'XXX S RXPR(XXX)=$P(RXPR1(XXX),"^",2)
.F WWWW=0:0 S WWWW=$O(RXRP1(WWWW)) Q:'WWWW S:$D(RXRP1(WWWW)) RXRP(WWWW)=1
I $G(PSOQFLAG) D RESET
EXIT K ACT,BCNUM,CBD,CNT,COM,DA,DEAD,DEL,DELCNT,DFN,DIRUT,DR,DTOUT,DUOUT,DTTM,GG,HOLD,HOLDPPL,OUT,PSOPULL,PSOWIN,PSOWINEN,PSODBQ,PPLHOLD,PPLHOLDX,HOLDPROF,RR,ZZZZ,PSDNAME,PSDDDATE,ZTSK,WWWW,RXRP,RXRP1,PSONOPRT,RXFL,RXRR
S PSOALRX="" F S PSOALRX=$O(PSOALRXS(PSOALRX)) Q:PSOALRX="" D PSOUL^PSSLOCK(PSOALRX)
K MW,PDUZ,PPL,PRF,PSPOP,PSOPROFL,RF,RFCNT,RX,RXPR,RXPR1,RXREC,SFN,GGGG,STOP,SUB,VADM,WARN,X,Y,Y(0),%,%W,%Y,%Y1,RXLTOP,PSOGET,PSOGETF,PSOGETFN
Q
;
TEST I $D(^PS(55,DFN,"P",CBD,0)) S RXREC=+^(0) I +$P($G(^PSRX(RXREC,"STA")),"^")=5,$D(^PS(52.5,"B",RXREC)) S SFN=+$O(^(RXREC,0)) Q:SFN'>0!($G(PSOQFLAG))!('$D(^PS(52.5,SFN,0))) S PSPOP=0 D:$G(PSODIV) DIV I 'PSPOP D CHKDEAD Q:DEAD D BEG
Q
;
CHKDEAD D DEM^VADPT S PSDNAME=$G(VADM(1)) I VADM(1)="" W !?10,"PATIENT NAME UNKNOWN" S DEAD=0 Q
I VADM(6)="" S DEAD=0 Q
S PSDDDATE=$P(VADM(6),"^",2) F ZZZZ=0:0 S ZZZZ=$O(^PS(55,DFN,"P",ZZZZ)) Q:'ZZZZ I $D(^PS(55,DFN,"P",ZZZZ,0)),$P($G(^(0)),"^") S (DA,RXREC)=$P(^(0),"^") I $O(^PS(52.5,"B",DA,0)) D DEAD
Q
;
DEAD S HOLD=DA,REA="C",COM="Died ("_$G(PSDDDATE)_")",DA=RXREC,DEAD=1 D CAN^PSOCAN W:'$G(WARN) !!,?10,$G(PSDNAME)," DIED ",$G(PSDDDATE) S WARN=1,DA=HOLD K HOLD,REA
Q
;
DIV I $D(^PS(52.5,SFN,0)),$D(^PSRX(+$P(^PS(52.5,SFN,0),"^"),2)),$P(^PS(52.5,SFN,0),"^",6)'=$G(PSOSITE) S RXREC=+$P(^PS(52.5,SFN,0),"^") D CKDIV
Q
;
CKDIV I '$P($G(PSOSYS),"^",2) W !!?10,$C(7),"Rx # ",$P(^PSRX(RXREC,0),"^")," is not a valid choice. (Different Division)" S PSPOP=1 Q
I $P($G(PSOSYS),"^",3) W !!?10,$C(7) S DIR("A")="Rx # "_$P(^PSRX(RXREC,0),"^")_" is from another division. Continue",DIR(0)="Y",DIR("B")="Y" D ^DIR K DIR I $G(DIRUT)!('Y) S PSPOP=1
Q
;
BEG I $P($G(^PSRX(RXREC,2)),"^",6)<DT,$P($G(^("STA")),"^")<11 D S DIE=52,DA=RXREC,DR="100///"_11 D ^DIE S DA=SFN,DIK="^PS(52.5," D ^DIK K DIE,DA,DIK W !!,"Rx #"_$P(^PSRX(RXREC,0),"^")_" has expired!" D PAUSE Q
.D EX^PSOSUTL
I '$D(^PS(52.5,SFN,0)) K PSOAL Q
I +$G(^PS(52.5,SFN,"P")) W !!,$C(7),">>> Rx #",$P(^PSRX(+$P(^(0),"^"),0),"^")_" has already been printed from suspense.",!,?5,"Use the reprint routine under the rx option to produce a label." D PAUSE Q
; PSO*7*427 - 7/24/2015
; Check if Label Log indicates a label was already printed. If it does, ask the user if they still
; want to print. If they don't, remove from Suspense queue, then quit.
N PRNTED,REFILL
S REFILL=$P($G(^PS(52.5,SFN,0)),"^",13)
S PRNTED=$$PRINTED^PSOSULBL(SFN,RXREC,REFILL)
I PRNTED N CONT S CONT=$$PRTQUES^PSOSUPRX(RXREC,REFILL) I CONT'=1 D Q
. I CONT=0 D REMOVE^PSOSULBL(SFN,RXREC,REFILL,DUZ,1,PRNTED)
. I CONT=-1 W !,"This prescription will not be pulled but will be left on suspense." D PAUSE
;
S PSOALRX=$P($G(^PS(52.5,SFN,0)),"^") I 'PSOALRX Q
;
; Check if we can lock the order
D PSOL^PSSLOCK(PSOALRX) I '$G(PSOMSG) D D PAUSE K PSOMSG,PSOALRX Q
.I $P($G(PSOMSG),"^",2)'="" W !!,"Rx: "_$P($G(^PSRX(PSOALRX,0)),"^")_" cannot be pulled from suspense.",!,$P($G(PSOMSG),"^",2),! Q
.W !!,"Another person is editing Rx "_$P($G(^PSRX(PSOALRX,0)),"^"),!,"It cannot be pulled from suspense.",!
;
; Set array for Rx's that can still be processed
S PSOALRXS(PSOALRX)=REFILL_"^"_SFN
K PSOMSG,PSOALRX
Q
;
PRF I $P(PSOPAR,"^",8),'$D(PRF(DFN)),$G(PSOPROFL) S HOLD=DFN D ^PSOPRF S DFN=HOLD,PRF(DFN)=""
Q
;
PSOINST I '$D(^PSRX(+$P(Y,"-",2),0)) W !!,$C(7),"Non-existent prescription" S OUT=1 Q
I $P(Y,"-")'=PSOINST W !!,$C(7),"The prescription is not from this institution." S OUT=1 Q
Q
;
; Populate RX Suspense and RX with new Routing Code and Pickup Method
MAIL I $D(PSOWINEN),$G(PSOWIN) S ^PSRX(RXREC,"MP")=$S(PSOWINEN'="":PSOWINEN,1:"")
MAILS I $G(RXPR(RXREC)) S DA(1)=RXREC,DA=RXPR(RXREC),DIE="^PSRX("_DA(1)_",""P"",",DR=".02///"_MW D ^DIE K DIE Q
I $G(RXPR1(RXREC)) S DA(1)=RXREC,DA=$P(RXPR1(RXREC),U,2),DIE="^PSRX("_DA(1)_",""P"",",DR=".02///"_MW D ^DIE K DIE Q
S RFCNT=0 F RR=0:0 S RR=$O(^PSRX(RXREC,1,RR)) Q:'RR S RFCNT=RR
I 'RFCNT S DA=RXREC,DIE=52,DR="11///"_MW D ^DIE
I RFCNT S DA(1)=RXREC,DA=RFCNT,DIE="^PSRX("_DA(1)_",1,",DR="2///"_MW D ^DIE
K DIE,RFCNT,RR
Q
;
RESET ;
; Reset Mail/Window value for all prescriptions in the RXRR array
N PRSDA
F PRSDA=0:0 S PRSDA=$O(RXRR(PRSDA)) Q:'PRSDA D RESETRX(PRSDA)
Q
;
RESETRX(RX) ;
; Reset fields in RX Suspense and Prescription files
; Input:
; RX: Prescription IEN
;
I '$G(RX) Q
N SFN,PRMW,PRMP,PRFILL,PRFILLN,PRPSRX,DIE,DA,DR,DTOUT
S SFN=$O(^PS(52.5,"B",RX,0))
I 'SFN Q
I '$D(^PS(52.5,SFN,0)) Q
S PRMW=$S($P($G(RXRR(RX)),"^")="":"M",1:$P($G(RXRR(RX)),"^")),PRMP=$P($G(RXRR(RX)),"^",2)
S PRFILL=$P($G(RXRR(RX)),"^",3),PRFILLN=$P($G(RXRR(RX)),"^",4)
S PRPSRX=$S($P($G(RXRR(RX)),"^",5)="":"M",1:$P($G(RXRR(RX)),"^",5))
I PRMW'="" S $P(^PS(52.5,SFN,0),"^",4)=PRMW D
.I PRFILL="P" D Q
..I $D(^PSRX(RX,"P",+$G(PRFILLN),0)) S $P(^PSRX(RX,"P",+$G(PRFILLN),0),"^",2)=$G(PRPSRX),$P(^PSRX(RX,"MP"),"^")=PRMP
.I PRFILL="R",$G(PRFILLN) S DA(1)=RX,DA=PRFILLN,DIE="^PSRX("_DA(1)_",1,",DR="2////"_PRPSRX D ^DIE K DIE
.I PRFILL="O" S DA=RX,DIE="^PSRX(",DR="11////"_PRPSRX D ^DIE K DIE
.S $P(^PSRX(RX,"MP"),"^")=PRMP
Q
;
PAUSE ;
W ! K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOSUPAT 11477 printed Sep 23, 2025@20:11:59 Page 2
PSOSUPAT ;BIR/RTR - Pull all Rx's from suspense for a patient ;03/01/96
+1 ;;7.0;OUTPATIENT PHARMACY;**8,130,185,427,544,562**;DEC 1997;Build 19
+2 ;External reference to ^PS(55 supported by DBIA 2228
+3 ;External reference to ^PSSLOCK supported by DBIA 2789
PAT NEW PSOALRX,PSOALRXS,PSOSKIP
+1 SET POP=0
KILL RXP,RXRR,RXFL,RXRP,RXPR,ASKED,BC,DELCNT,WARN,PSOAL,PSOPROFL,PSOQFLAG,PSOPULL,PSOWIN,PSOWINEN,PPLHOLD,PPLHOLDX
+2 WRITE !
SET DIR("A")="Are you entering the patient name or barcode"
SET DIR(0)="SBO^P:Patient Name;B:Barcode"
+3 SET DIR("?")="Enter P if you are going to enter the patient name. Enter B if you are going to enter or wand the barcode."
+4 DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO ^PSOSUPRX
SET BC=Y
DO NOW^%DTC
SET TM=$EXTRACT(%,1,12)
SET TM1=$PIECE(TM,".",2)
BC SET (OUT,POP)=0
IF BC="B"
WRITE !
SET DIR("A")="Enter/wand barcode"
SET DIR(0)="FO^5:20"
SET DIR("?")="Enter or wand a prescription barcode for the patient you wish to pull all Rx's for"
DO ^DIR
KILL DIR
if $GET(DIRUT)
GOTO PAT
SET BCNUM=Y
Begin DoDot:1
+1 DO PSOINST
if OUT
QUIT
SET RX=$PIECE(BCNUM,"-",2)
if $DATA(^PSRX(RX,0))
Begin DoDot:2
+2 SET (DFN,PSODFN)=$PIECE(^PSRX(RX,0),"^",2)
WRITE " ",$PIECE($GET(^DPT(DFN,0)),"^")
+3 DO ICN^PSODPT(DFN)
End DoDot:2
+4 IF '$DATA(^PSRX(RX,0))
WRITE !,$CHAR(7),"NO PRESCRIPTION RECORD FOR THIS BARCODE."
SET OUT=1
End DoDot:1
+5 if OUT
GOTO BC
NAM IF BC="P"
WRITE !
SET DIC(0)="AEMZQ"
SET DIC="^DPT("
SET DIC("S")="I $D(^PS(52.5,""AC"",+Y))!($D(^PS(52.5,""AG"",+Y)))"
DO ^DIC
KILL DIC
if $DATA(DTOUT)!($DATA(DUOUT))!(Y<0)
GOTO PAT
SET (DFN,PSODFN)=+Y
+1 SET PSOLOUD=1
if $PIECE($GET(^PS(55,PSODFN,0)),"^",6)'=2
DO EN^PSOHLUP(PSODFN)
KILL PSOLOUD
+2 ;
+3 ; PSO*7*427 - DMB - 7/24/2015 - Remove call to QUES^PSOSUPRX so that a ECME reject would not cause the entire process to abort. TEST/BEG still checks
+4 ; for valid data, labels already printed, and locks but does not build PPLHOLD/arrays nor does it call QUES^PSOSPRX. If there still valid Rx's
+5 ; to process, then ask Routing, Pickup Method and whether to Pull the Rx's. After that, we call ECME (but only quit for each
+6 ; RX if it fails), then add to PPLHOLD/arrays, and update the Routing/Pickup Method for RX SUSPENSE and the RX.
+7 SET (ASKED,DELCNT,WARN)=0
+8 FOR CBD=0:0
SET CBD=$ORDER(^PS(55,DFN,"P",CBD))
if CBD'>0
QUIT
DO TEST
+9 IF $GET(PSOQFLAG)
GOTO EXIT
+10 ;
+11 ; After the TEST/BEG checks, check if there are any prescription left to process
+12 IF '$DATA(PSOALRXS)
WRITE !!,"There are no prescriptions left to process - exiting!"
DO PAUSE
GOTO EXIT
+13 ;
+14 ; Get Routing
+15 WRITE !
+16 KILL DIR,DTOUT
SET DIR("A")="Select routing for Rx(s)"
SET DIR(0)="S^M:MAIL;W:WINDOW"
SET DIR("B")="WINDOW"
DO ^DIR
SET MW=Y
+17 IF Y["^"!($DATA(DTOUT))
WRITE !!,"Nothing pulled from suspense!"
DO PAUSE
GOTO EXIT
+18 IF MW="W"
SET SUSROUTE=1
+19 ;
+20 ; If Routing is Window and site paramter to ask Method of Pickup, then get Method of Pickup
+21 IF MW="W"
IF $PIECE(PSOPAR,"^",12)
KILL DIR,DTOUT,DUOUT
SET DIR(0)="52,35"
DO ^DIR
SET PSOWIN=1
SET PSOWINEN=Y
IF $GET(DTOUT)!$GET(DUOUT)
WRITE !!,"Nothing pulled from suspense!"
DO PAUSE
GOTO EXIT
+22 ;
+23 ; Ask to Pull Rx's
+24 WRITE !!
+25 KILL DIR
+26 SET DIR("A")="Pull Rx(s) and delete from suspense"
SET DIR("B")="Y"
SET DIR(0)="Y"
+27 SET DIR("?",1)="Enter Yes to pull selected Rx(s) from suspense. Since Rx(s) pulled early from"
SET DIR("?",2)="suspense are not associated with a printed batch, these Rx(s) cannot be"
+28 SET DIR("?",3)="reprinted from suspense using the 'Reprint batches from Suspense' option."
SET DIR("?")="Therefore, any Rx(s) pulled early from suspense will be deleted from suspense."
+29 DO ^DIR
+30 IF Y'=1
WRITE $CHAR(7),!!,"Nothing pulled from suspense!"
DO PAUSE
GOTO EXIT
+31 ;
+32 ; Loop through the remaining Rx and process
+33 SET RXREC=""
FOR
SET RXREC=$ORDER(PSOALRXS(RXREC))
if RXREC=""
QUIT
Begin DoDot:1
+34 ; Resubmit to ECME if needed and check results
+35 NEW RFL
SET RFL=$PIECE(PSOALRXS(RXREC),U,1)
IF RFL=""
SET RFL=$$LSTRFL^PSOBPSU1(RXREC)
+36 ;
+37 ; Do not send a claim if the last submission was rejected and
+38 ; all rejects have been closed.
+39 ;
+40 SET PSOSKIP=0
+41 IF $$SEND^PSOBPSU2(RXREC,RFL)
Begin DoDot:2
+42 DO ECMESND^PSOBPSU1(RXREC,RFL,,"PE")
+43 ; Quit if there is an unresolved TRICARE/CHAMPVA non-billable reject code
IF $$PSOET^PSOREJP3(RXREC,RFL)
SET PSOSKIP=1
QUIT
+44 NEW PSOTRIC
SET PSOTRIC=$$TRIC^PSOREJP1(RXREC,RFL)
+45 IF $$FIND^PSOREJUT(RXREC,RFL)
IF $$HDLG^PSOREJU1(RXREC,RFL,"79,88,943","PE","IOQ","I")="Q"
SET PSOSKIP=1
QUIT
+46 ;No label if discontinued via Reject Notification screen
IF $PIECE($GET(^PSRX(RXREC,"STA")),"^")=12
SET PSOSKIP=1
QUIT
+47 QUIT
End DoDot:2
IF PSOSKIP
QUIT
+48 ;
+49 ; Put on queue to be printed
+50 SET SFN=$PIECE(PSOALRXS(RXREC),U,2)
+51 SET DA=$PIECE(^PS(52.5,SFN,0),"^")
SET RXPR(DA)=+$PIECE(^(0),"^",5)
SET RXFL(DA)=$PIECE($GET(^(0)),"^",13)
+52 IF $LENGTH($GET(PPLHOLD))<240
SET PPLHOLD=$SELECT($GET(PPLHOLD)="":$PIECE(^PS(52.5,SFN,0),"^"),1:$GET(PPLHOLD)_","_+^PS(52.5,SFN,0))
if $PIECE(^PS(52.5,SFN,0),"^",12)
SET RXRP(DA)=1
+53 IF $LENGTH($GET(PPLHOLD))'<240
SET PPLHOLDX=$SELECT($GET(PPLHOLDX)="":$PIECE(^PS(52.5,SFN,0),"^"),1:$GET(PPLHOLDX)_","_+^PS(52.5,SFN,0))
if $GET(RXPR(DA))
SET RXPR1(DA)=DA_"^"_RXPR(DA)
if $PIECE(^PS(52.5,SFN,0),"^",12)
SET RXRP1(DA)=1
KILL RXPR(DA)
+54 IF '$DATA(^PSRX(RXREC,1))
IF '$GET(RXPR(RXREC))
IF '$GET(RXPR1(RXREC))
SET PSOPROFL=1
+55 ;
+56 ; Save off old Routing/Method of Pickup values
+57 SET PSOGET="M"
DO GETMW^PSOSUPOE
+58 SET RXRR(RXREC)=$SELECT($PIECE(^PS(52.5,SFN,0),"^",4)="W":"W",1:"M")_"^"_$PIECE($GET(^PSRX(RXREC,"MP")),"^")_"^"_$GET(PSOGETF)_"^"_$GET(PSOGETFN)_"^"_$SELECT($GET(PSOGET)="W":"W",1:"M")
+59 ;
+60 ; Update Routing and Method of Pickup
+61 SET $PIECE(^PS(52.5,SFN,0),"^",4)=MW
+62 DO MAIL
End DoDot:1
+63 ;
+64 ;S HOLDPROF=$G(PSOPROFL) K PSOPROFL
+65 ;I $D(PSOPART) S (PSOPULL,PSODBQ)=1 F RR=0:0 S RR=$O(PSOPART(RR)) Q:'RR S PDUZ=DUZ,PPL=RR,RXP=PSOPART(RR) D Q^PSORXL
+66 ;S PSOPROFL=HOLDPROF I $D(ZTSK),'$G(PPLHOLD) W !!,"LABEL(S) ARE QUEUED TO PRINT",!
+67 FOR GGGG=0:0
SET GGGG=$ORDER(RXPR(GGGG))
if 'GGGG
QUIT
if '$GET(RXPR(GGGG))
KILL RXPR(GGGG)
+68 KILL RXP,PPL
SET PDUZ=DUZ
SET PSONOPRT=1
+69 IF $GET(PPLHOLD)'=""
SET PPL=PPLHOLD
if $GET(SUSROUTE)
SET BBRX(1)=PPL
SET HOLDPPL=PPL
SET PSOPULL=1
SET PSODBQ=1
SET RXLTOP=1
DO WIND^PSOSUPRX
DO Q^PSORXL
IF '$GET(PSOQFLAG)
WRITE !!,"LABEL(S) ARE QUEUED TO PRINT",!
SET PPL=$PIECE(HOLDPPL,",")
DO PRF
if '$GET(PSOQFLAG)
Begin DoDot:1
+70 IF $PIECE(PSOPAR,"^",8)
IF $GET(PSOPROFL)
WRITE !!,"PROFILE(S) ARE QUEUED TO PRINT"
End DoDot:1
SET PSOQFLAG=0
+71 ;call to bingo board
+72 IF $GET(PPLHOLDX)
IF '$GET(PSOQGLAG)
IF $GET(SUSROUTE)
SET BBRX(2)=PPLHOLDX
+73 if $GET(BINGRTE)&($DATA(DISGROUP))&('$GET(PSOQFLAG))
DO ^PSOBING1
KILL BINGRTE,BBRX
+74 IF $GET(PPLHOLDX)
IF '$GET(PSOQFLAG)
Begin DoDot:1
+75 FOR XXX=0:0
SET XXX=$ORDER(RXPR1(XXX))
if 'XXX
QUIT
SET RXPR(XXX)=$PIECE(RXPR1(XXX),"^",2)
+76 FOR WWWW=0:0
SET WWWW=$ORDER(RXRP1(WWWW))
if 'WWWW
QUIT
if $DATA(RXRP1(WWWW))
SET RXRP(WWWW)=1
End DoDot:1
SET PDUZ=DUZ
SET PPL=PPLHOLDX
SET PSNP=0
SET (PSODBQ,PSOPULL)=1
DO Q^PSORXL
+77 IF $GET(PSOQFLAG)
DO RESET
EXIT KILL ACT,BCNUM,CBD,CNT,COM,DA,DEAD,DEL,DELCNT,DFN,DIRUT,DR,DTOUT,DUOUT,DTTM,GG,HOLD,HOLDPPL,OUT,PSOPULL,PSOWIN,PSOWINEN,PSODBQ,PPLHOLD,PPLHOLDX,HOLDPROF,RR,ZZZZ,PSDNAME,PSDDDATE,ZTSK,WWWW,RXRP,RXRP1,PSONOPRT,RXFL,RXRR
+1 SET PSOALRX=""
FOR
SET PSOALRX=$ORDER(PSOALRXS(PSOALRX))
if PSOALRX=""
QUIT
DO PSOUL^PSSLOCK(PSOALRX)
+2 KILL MW,PDUZ,PPL,PRF,PSPOP,PSOPROFL,RF,RFCNT,RX,RXPR,RXPR1,RXREC,SFN,GGGG,STOP,SUB,VADM,WARN,X,Y,Y(0),%,%W,%Y,%Y1,RXLTOP,PSOGET,PSOGETF,PSOGETFN
+3 QUIT
+4 ;
TEST IF $DATA(^PS(55,DFN,"P",CBD,0))
SET RXREC=+^(0)
IF +$PIECE($GET(^PSRX(RXREC,"STA")),"^")=5
IF $DATA(^PS(52.5,"B",RXREC))
SET SFN=+$ORDER(^(RXREC,0))
if SFN'>0!($GET(PSOQFLAG))!('$DATA(^PS(52.5,SFN,0)))
QUIT
SET PSPOP=0
if $GET(PSODIV)
DO DIV
IF 'PSPOP
DO CHKDEAD
if DEAD
QUIT
DO BEG
+1 QUIT
+2 ;
CHKDEAD DO DEM^VADPT
SET PSDNAME=$GET(VADM(1))
IF VADM(1)=""
WRITE !?10,"PATIENT NAME UNKNOWN"
SET DEAD=0
QUIT
+1 IF VADM(6)=""
SET DEAD=0
QUIT
+2 SET PSDDDATE=$PIECE(VADM(6),"^",2)
FOR ZZZZ=0:0
SET ZZZZ=$ORDER(^PS(55,DFN,"P",ZZZZ))
if 'ZZZZ
QUIT
IF $DATA(^PS(55,DFN,"P",ZZZZ,0))
IF $PIECE($GET(^(0)),"^")
SET (DA,RXREC)=$PIECE(^(0),"^")
IF $ORDER(^PS(52.5,"B",DA,0))
DO DEAD
+3 QUIT
+4 ;
DEAD SET HOLD=DA
SET REA="C"
SET COM="Died ("_$GET(PSDDDATE)_")"
SET DA=RXREC
SET DEAD=1
DO CAN^PSOCAN
if '$GET(WARN)
WRITE !!,?10,$GET(PSDNAME)," DIED ",$GET(PSDDDATE)
SET WARN=1
SET DA=HOLD
KILL HOLD,REA
+1 QUIT
+2 ;
DIV IF $DATA(^PS(52.5,SFN,0))
IF $DATA(^PSRX(+$PIECE(^PS(52.5,SFN,0),"^"),2))
IF $PIECE(^PS(52.5,SFN,0),"^",6)'=$GET(PSOSITE)
SET RXREC=+$PIECE(^PS(52.5,SFN,0),"^")
DO CKDIV
+1 QUIT
+2 ;
CKDIV IF '$PIECE($GET(PSOSYS),"^",2)
WRITE !!?10,$CHAR(7),"Rx # ",$PIECE(^PSRX(RXREC,0),"^")," is not a valid choice. (Different Division)"
SET PSPOP=1
QUIT
+1 IF $PIECE($GET(PSOSYS),"^",3)
WRITE !!?10,$CHAR(7)
SET DIR("A")="Rx # "_$PIECE(^PSRX(RXREC,0),"^")_" is from another division. Continue"
SET DIR(0)="Y"
SET DIR("B")="Y"
DO ^DIR
KILL DIR
IF $GET(DIRUT)!('Y)
SET PSPOP=1
+2 QUIT
+3 ;
BEG IF $PIECE($GET(^PSRX(RXREC,2)),"^",6)<DT
IF $PIECE($GET(^("STA")),"^")<11
Begin DoDot:1
+1 DO EX^PSOSUTL
End DoDot:1
SET DIE=52
SET DA=RXREC
SET DR="100///"_11
DO ^DIE
SET DA=SFN
SET DIK="^PS(52.5,"
DO ^DIK
KILL DIE,DA,DIK
WRITE !!,"Rx #"_$PIECE(^PSRX(RXREC,0),"^")_" has expired!"
DO PAUSE
QUIT
+2 IF '$DATA(^PS(52.5,SFN,0))
KILL PSOAL
QUIT
+3 IF +$GET(^PS(52.5,SFN,"P"))
WRITE !!,$CHAR(7),">>> Rx #",$PIECE(^PSRX(+$PIECE(^(0),"^"),0),"^")_" has already been printed from suspense.",!,?5,"Use the reprint routine under the rx option to produce a label."
DO PAUSE
QUIT
+4 ; PSO*7*427 - 7/24/2015
+5 ; Check if Label Log indicates a label was already printed. If it does, ask the user if they still
+6 ; want to print. If they don't, remove from Suspense queue, then quit.
+7 NEW PRNTED,REFILL
+8 SET REFILL=$PIECE($GET(^PS(52.5,SFN,0)),"^",13)
+9 SET PRNTED=$$PRINTED^PSOSULBL(SFN,RXREC,REFILL)
+10 IF PRNTED
NEW CONT
SET CONT=$$PRTQUES^PSOSUPRX(RXREC,REFILL)
IF CONT'=1
Begin DoDot:1
+11 IF CONT=0
DO REMOVE^PSOSULBL(SFN,RXREC,REFILL,DUZ,1,PRNTED)
+12 IF CONT=-1
WRITE !,"This prescription will not be pulled but will be left on suspense."
DO PAUSE
End DoDot:1
QUIT
+13 ;
+14 SET PSOALRX=$PIECE($GET(^PS(52.5,SFN,0)),"^")
IF 'PSOALRX
QUIT
+15 ;
+16 ; Check if we can lock the order
+17 DO PSOL^PSSLOCK(PSOALRX)
IF '$GET(PSOMSG)
Begin DoDot:1
+18 IF $PIECE($GET(PSOMSG),"^",2)'=""
WRITE !!,"Rx: "_$PIECE($GET(^PSRX(PSOALRX,0)),"^")_" cannot be pulled from suspense.",!,$PIECE($GET(PSOMSG),"^",2),!
QUIT
+19 WRITE !!,"Another person is editing Rx "_$PIECE($GET(^PSRX(PSOALRX,0)),"^"),!,"It cannot be pulled from suspense.",!
End DoDot:1
DO PAUSE
KILL PSOMSG,PSOALRX
QUIT
+20 ;
+21 ; Set array for Rx's that can still be processed
+22 SET PSOALRXS(PSOALRX)=REFILL_"^"_SFN
+23 KILL PSOMSG,PSOALRX
+24 QUIT
+25 ;
PRF IF $PIECE(PSOPAR,"^",8)
IF '$DATA(PRF(DFN))
IF $GET(PSOPROFL)
SET HOLD=DFN
DO ^PSOPRF
SET DFN=HOLD
SET PRF(DFN)=""
+1 QUIT
+2 ;
PSOINST IF '$DATA(^PSRX(+$PIECE(Y,"-",2),0))
WRITE !!,$CHAR(7),"Non-existent prescription"
SET OUT=1
QUIT
+1 IF $PIECE(Y,"-")'=PSOINST
WRITE !!,$CHAR(7),"The prescription is not from this institution."
SET OUT=1
QUIT
+2 QUIT
+3 ;
+4 ; Populate RX Suspense and RX with new Routing Code and Pickup Method
MAIL IF $DATA(PSOWINEN)
IF $GET(PSOWIN)
SET ^PSRX(RXREC,"MP")=$SELECT(PSOWINEN'="":PSOWINEN,1:"")
MAILS IF $GET(RXPR(RXREC))
SET DA(1)=RXREC
SET DA=RXPR(RXREC)
SET DIE="^PSRX("_DA(1)_",""P"","
SET DR=".02///"_MW
DO ^DIE
KILL DIE
QUIT
+1 IF $GET(RXPR1(RXREC))
SET DA(1)=RXREC
SET DA=$PIECE(RXPR1(RXREC),U,2)
SET DIE="^PSRX("_DA(1)_",""P"","
SET DR=".02///"_MW
DO ^DIE
KILL DIE
QUIT
+2 SET RFCNT=0
FOR RR=0:0
SET RR=$ORDER(^PSRX(RXREC,1,RR))
if 'RR
QUIT
SET RFCNT=RR
+3 IF 'RFCNT
SET DA=RXREC
SET DIE=52
SET DR="11///"_MW
DO ^DIE
+4 IF RFCNT
SET DA(1)=RXREC
SET DA=RFCNT
SET DIE="^PSRX("_DA(1)_",1,"
SET DR="2///"_MW
DO ^DIE
+5 KILL DIE,RFCNT,RR
+6 QUIT
+7 ;
RESET ;
+1 ; Reset Mail/Window value for all prescriptions in the RXRR array
+2 NEW PRSDA
+3 FOR PRSDA=0:0
SET PRSDA=$ORDER(RXRR(PRSDA))
if 'PRSDA
QUIT
DO RESETRX(PRSDA)
+4 QUIT
+5 ;
RESETRX(RX) ;
+1 ; Reset fields in RX Suspense and Prescription files
+2 ; Input:
+3 ; RX: Prescription IEN
+4 ;
+5 IF '$GET(RX)
QUIT
+6 NEW SFN,PRMW,PRMP,PRFILL,PRFILLN,PRPSRX,DIE,DA,DR,DTOUT
+7 SET SFN=$ORDER(^PS(52.5,"B",RX,0))
+8 IF 'SFN
QUIT
+9 IF '$DATA(^PS(52.5,SFN,0))
QUIT
+10 SET PRMW=$SELECT($PIECE($GET(RXRR(RX)),"^")="":"M",1:$PIECE($GET(RXRR(RX)),"^"))
SET PRMP=$PIECE($GET(RXRR(RX)),"^",2)
+11 SET PRFILL=$PIECE($GET(RXRR(RX)),"^",3)
SET PRFILLN=$PIECE($GET(RXRR(RX)),"^",4)
+12 SET PRPSRX=$SELECT($PIECE($GET(RXRR(RX)),"^",5)="":"M",1:$PIECE($GET(RXRR(RX)),"^",5))
+13 IF PRMW'=""
SET $PIECE(^PS(52.5,SFN,0),"^",4)=PRMW
Begin DoDot:1
+14 IF PRFILL="P"
Begin DoDot:2
+15 IF $DATA(^PSRX(RX,"P",+$GET(PRFILLN),0))
SET $PIECE(^PSRX(RX,"P",+$GET(PRFILLN),0),"^",2)=$GET(PRPSRX)
SET $PIECE(^PSRX(RX,"MP"),"^")=PRMP
End DoDot:2
QUIT
+16 IF PRFILL="R"
IF $GET(PRFILLN)
SET DA(1)=RX
SET DA=PRFILLN
SET DIE="^PSRX("_DA(1)_",1,"
SET DR="2////"_PRPSRX
DO ^DIE
KILL DIE
+17 IF PRFILL="O"
SET DA=RX
SET DIE="^PSRX("
SET DR="11////"_PRPSRX
DO ^DIE
KILL DIE
+18 SET $PIECE(^PSRX(RX,"MP"),"^")=PRMP
End DoDot:1
+19 QUIT
+20 ;
PAUSE ;
+1 WRITE !
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to continue"
DO ^DIR
KILL DIR
+2 QUIT
