PSOSUPRX ;BIR/RTR - Suspense pull early ;3/1/96
;;7.0;OUTPATIENT PHARMACY;**8,36,130,185,148,287,358,385,427,544,562**;DEC 1997;Build 19
;External reference to ^PS(55 supported by DBIA 2228
;External reference to ^PSSLOCK supported by DBIA 2789
ST N PSOPLLRX D:'$D(PSOPAR) ^PSOLSET G:'$D(PSOPAR) ST
N SUSROUTE,BBRX S SUSPT=1,PSLION=$G(PSOLAP),PSOQFLAG=0 W !! S DIR("A")="Print a specific Rx # or all Rx's for a patient",DIR(0)="SBO^S:SPECIFIC RX;A:ALL RXs FOR A PATIENT"
S DIR("?",1)="Enter 'S' to print a suspended prescription label early.",DIR("?")="Enter 'A' to print all prescription suspense labels for a patient."
D ^DIR K DIR S SA=Y G:$G(DIRUT)!(Y<0) EXIT I SA="A" D ^PSOSUPAT G EXIT
LU D NOW^%DTC S TM=$E(%,1,12),TM1=$P(TM,".",2) ;setup start time for bingo
K SUSROUTE,BBRX,RXP,RXFL,RXRP,RXPR,RXRR
K PSOPROFL,PSOE,RXP1,RXPR,PRF,PSOWIN,PSOWINEN S MW="" W ! S DIR("A")="Select SUSPENDED Rx #: ",DIR(0)="FOA",DIR("?")="Enter the Rx # or wand the barcode. For a list of suspense prescriptions, type '??'",DIR("??")="^D LIST^PSOSUPRX"
S POP=0 D ^DIR K DIR G:$D(DIRUT)!('Y) ST S OUT=0 D:Y["-" PSOINST^PSOSUPAT G:OUT LU
S:Y'["-" X=Y S:Y["-" Y=$P(Y,"-",2),X=$P(^PSRX(+Y,0),"^") K Y G:$G(X)="" ST K DIC W ! D S DIC="^PS(52.5,",DIC(0)="ZQE" D ^DIC K DIC,PSOSPINT W ! G:$D(DTOUT)!($D(DUOUT)) ST G LU:Y<0 S RXREC=+Y(0),SFN=+Y
.S PSOSPINT=X S DIC("S")="I $D(^PSRX(+$P(^PS(52.5,+Y,0),""^""),0)),$P($G(^(""STA"")),""^"")=5,$P($G(^(0)),""^"")=PSOSPINT"
S PSOPLLRX=$G(RXREC) I PSOPLLRX D PSOL^PSSLOCK(PSOPLLRX) I '$G(PSOMSG) D K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR K PSOMSG,PSOPLLRX,X,Y G LU
.I $P($G(PSOMSG),"^",2)'="" W !,$P($G(PSOMSG),"^",2),! Q
.W !,"Another person is editing this order.",!
K PSOMSG
S PSOLOUD=1 D:$P($G(^PS(55,$P(Y(0),"^",3),0)),"^",6)'=2 EN^PSOHLUP($P(Y(0),"^",3)) K PSOLOUD
I $G(PSODIV),$P($G(^PS(52.5,SFN,0)),"^",6)'=$G(PSOSITE) S PSPOP=0,PSOSAV=Y,PSOSAVO=Y(0) D CKDIV^PSOSUPAT S Y=PSOSAV,Y(0)=PSOSAVO K PSOSAV,PSOSAVO,PSOPRFLG D:PSPOP UNLK G:PSPOP LU
D CHKDEAD W:DEAD !!,?10,$G(PSDNAME)," DIED ",$G(PSDDDATE) D:'DEAD BEG D:$G(PSOQFLAG) RESET^PSOSUPAT K PSOQFLAG,PSOPULL D UNLK G LU
EXIT K ASKED,CBD,CNT,COM,DA,DEAD,DEL,DFN,DIRUT,DR,DTOUT,DUOUT,HOLDDFN,HDSFN,JJ,MW,OLD,OUT,PDUZ,PSODFN,TM,TM1,RXLTOP,RXRR,PSOGET,PSOGETF,PSOGETFN
K PPL,PSOPULL,PSOWIN,PSOWINEN,PRF,PSODBQ,PSPOP,PSOQFLAG,PSOPROFL,RF,RFCNT,RX,RXP1,RXPR,RXREC,SA,SFN,STOP,SUSPT,VADM,ZTSK,RXFL
K X,Y,Z,PSOPRFLG,PSDDDATE,PSDNAME,ZZZZ,RXRP Q
CHKDEAD S (DFN,PSODFN)=+$P(Y(0),"^",3) D DEM^VADPT S PSDNAME=$G(VADM(1)) I VADM(1)="" W !?10,"PATIENT UNKNOWN" S DEAD=0 Q
I VADM(6)="" S DEAD=0 Q
S PSDDDATE=$P(VADM(6),"^",2),(PDUZ,PSOCLC)=DUZ 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 S DA=HOLD K HOLD,REA Q
BEG S PDUZ=DUZ I +$G(^PS(52.5,SFN,"P")) W !,">>> Rx #",$P(^PSRX(+$P(^(0),"^"),0),"^")," ALREADY PRINTED FROM SUSPENSE.",!,?5,"USE THE REPRINT OPTION TO REPRINT LABEL.",! Q
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!" F PSOE=1:1:3 W "." H 1
.D EX^PSOSUTL
I '$D(^PS(52.5,SFN,0)) K PSOE 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(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 ICN^PSODPT(+$P(^PSRX(RXREC,0),"^",2))
S RXFL(RXREC)=$P($G(^PS(52.5,SFN,0)),"^",13)
S HDSFN=SFN,(PPL,DA)=RXREC S:$P(^PS(52.5,SFN,0),"^",5) (RXP1,RXPR(RXREC))=$P(^(0),"^",5)
S:$P(^PS(52.5,SFN,0),"^",12) RXRP(RXREC)=1 D QUES Q:$G(PSOQFLAG)
S (PSOPULL,PSODBQ,PSONOPRT)=1,RXLTOP=1 D WIND D Q^PSORXL S PPL=RXREC
I '$G(PSOQFLAG) W !!,"LABEL QUEUED TO PRINT",! K RX
I '$G(PSOQFLAG) D PRF D:'$G(PSOQFLAG) S PSOQFLAG=0
.S:'$G(PSOPROFL) PSOPRFLG=1 W:$G(PSOPROFL) !!,"PROFILE QUEUED TO PRINT"
K PSONOPRT,RXPR,RXP1
S PPL=RXREC
;call to bingo board
S:$G(SUSROUTE) BBRX(1)=PPL
D:$G(BINGRTE)&($D(DISGROUP))&('$G(PSOQFLAG)) ^PSOBING1 K BINGRTE,BBRX
Q
; PSO*427-DMB-7/27/2015. PSOSUPAT (Pull Early for all Rx for a patient) used to call QUES. Because of that, the code below
; had checks to make sure that Routing, Method of P/U, and Pull Rx question was only asked for the first Rx. Now that PSOSUPAT
; no longer calls QUES, those checks/variables were removed.
QUES ;
; Ask Routing, method of pickup, and whether to continue. Also update RX and RX Suspense records with new values. Save off old
; values in case we need to reset them later.
W ! K DIR S DIR("A")="Select routing for Rx(s)",DIR(0)="S^M:MAIL;W:WINDOW",DIR("B")="WINDOW" D ^DIR K DIR S MW=Y I Y["^"!($D(DTOUT)) W !!?5,"Nothing pulled from suspense!",! S PSOQFLAG=1 Q
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")
S:$G(MW)="W" SUSROUTE=1 S $P(^PS(52.5,SFN,0),"^",4)=$G(MW) D:$G(MW)="W" Q:$G(PSOQFLAG) D MAIL^PSOSUPAT
.I $P(PSOPAR,"^",12) S DA=RXREC,DIE="^PSRX(",DR=35 D ^DIE S:$D(Y)!($D(DTOUT)) PSOQFLAG=1 Q:$G(PSOQFLAG) S PSOWIN=1,PSOWINEN=$P($G(^PSRX(RXREC,"MP")),"^") Q
W !! S DIR("A")="Pull Rx(s) and delete from suspense",DIR("B")="Y",DIR(0)="Y" D D ^DIR K DIR I Y'=1 W $C(7),!!?5,"Nothing pulled from suspense!",! S PSOQFLAG=1 Q
.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."
S HDSFN=SFN
;
; - Submitting Rx to ECME for 3rd Party Billing
N RFL S RFL=RXFL(RXREC) I RFL="" S RFL=$$LSTRFL^PSOBPSU1(RXREC)
;
; Do not send a claim if the last submission was rejected and
; all rejects have been closed.
;
I '$$SEND^PSOBPSU2(RXREC,RFL) Q
;
D ECMESND^PSOBPSU1(RXREC,RFL,,"PE")
; Quit if there is an unresolved TRICARE/CHAMPVA non-billable reject code, PSO*7*358
I $$PSOET^PSOREJP3(RXREC,RFL) S PSOQFLAG=1 Q
N PSOTRIC S PSOTRIC="",PSOTRIC=$$TRIC^PSOREJP1(RXREC,RFL,.PSOTRIC)
I $$FIND^PSOREJUT(RXREC,RFL),$$HDLG^PSOREJU1(RXREC,RFL,"79,88,943","PE","IOQ","I")="Q" S PSOQFLAG=1 Q
I $P($G(^PSRX(RXREC,"STA")),"^")=12 S PSOQFLAG=1 Q ;No label if discontinued via Reject Notification screen
;
Q
PRF S:'$D(DFN) DFN=+$P(^PS(52.5,SFN,0),"^",3) I $P(PSOPAR,"^",8),'$D(^PSRX(RXREC,1)),'$D(PRF(DFN)),'$G(RXP1) S PSOPROFL=1,HOLDDFN=DFN D ^PSOPRF S DFN=HOLDDFN K HOLDDFN S PRF(DFN)=""
Q
LIST S X="?",DIC("S")="I $D(^PSRX(+$P(^PS(52.5,+Y,0),""^""),0)),$P($G(^(""STA"")),""^"")=5",DIC="^PS(52.5,",DIC(0)="ZQ" D ^DIC K DIC W ! Q:Y<0!($D(DTOUT)) Q
NEXT S PSOX("IRXN")=RX D NEXT^PSOUTIL(.PSOX) S NEXT=$P(PSOX("RX3"),"^",2)
S DA=RX,DIE=52,DR="102///"_NEXT D ^DIE K DIE Q:$D(DTOUT)!($D(DUOUT))
K NEXT,PSOX Q
WIND ;
N RRT,RRTT,XXXX,JJJJ,PSINTRX,RTETEST,PSOPSO,SSSS
S BINGRTE=0
S RRT=1 F XXXX=1:1:$L(PPL) S RRTT=$E(PPL,XXXX) I RRTT="," S RRT=RRT+1
F JJJJ=1:1:RRT Q:$G(BINGRTE) S PSINTRX=$P(PPL,",",JJJJ) I $D(^PSRX(+PSINTRX,0)) D
.I $G(RXPR(PSINTRX)) S RTETEST=$P($G(^PSRX(PSINTRX,"P",RXPR(PSINTRX),0)),"^",2) S:RTETEST="W" BINGRTE=1 Q
.S PSOPSO=0 F SSSS=0:0 S SSSS=$O(^PSRX(PSINTRX,1,SSSS)) Q:'SSSS S PSOPSO=SSSS
.I 'PSOPSO S RTETEST=$P($G(^PSRX(PSINTRX,0)),"^",11) S:RTETEST="W" BINGRTE=1 Q
.I PSOPSO S RTETEST=$P($G(^PSRX(PSINTRX,1,PSOPSO,0)),"^",2) S:RTETEST="W" BINGRTE=1 Q
Q
UNLK ;Unlock prescription
Q:'$G(PSOPLLRX)
D PSOUL^PSSLOCK(PSOPLLRX)
K PSOPLLRX
Q
;
PRTQUES(RX,RFL) ;
; Prompt if the user wants to continue when a label has been printed already
; Input:
; RX - Prescription (#52) file IEN
; RFL - Fill Number
; Output:
; 0 - Do not continue (user said No)
; 1 - Continue (user said Yes)
; -1 - Up-arrow, time-out, invalid parameter or any other non-YES/NO response
;
I '$G(RX) Q -1
I $G(RFL)="" S RFL=$$LSTRFL^PSOBPSU1(RX)
;
N DIR,Y,DIRUT,DTOUT,DIRUT,DIROUT
W !!,"Label for Rx#",$P($G(^PSRX(RX,0)),"^")," Fill#",RFL," has already been printed"
S DIR(0)="Y",DIR("A")="Do you want to continue",DIR("B")="No"
D ^DIR
I Y=0 Q 0
I Y=1 Q 1
Q -1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOSUPRX 8850 printed Sep 23, 2025@20:12:01 Page 2
PSOSUPRX ;BIR/RTR - Suspense pull early ;3/1/96
+1 ;;7.0;OUTPATIENT PHARMACY;**8,36,130,185,148,287,358,385,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
ST NEW PSOPLLRX
if '$DATA(PSOPAR)
DO ^PSOLSET
if '$DATA(PSOPAR)
GOTO ST
+1 NEW SUSROUTE,BBRX
SET SUSPT=1
SET PSLION=$GET(PSOLAP)
SET PSOQFLAG=0
WRITE !!
SET DIR("A")="Print a specific Rx # or all Rx's for a patient"
SET DIR(0)="SBO^S:SPECIFIC RX;A:ALL RXs FOR A PATIENT"
+2 SET DIR("?",1)="Enter 'S' to print a suspended prescription label early."
SET DIR("?")="Enter 'A' to print all prescription suspense labels for a patient."
+3 DO ^DIR
KILL DIR
SET SA=Y
if $GET(DIRUT)!(Y<0)
GOTO EXIT
IF SA="A"
DO ^PSOSUPAT
GOTO EXIT
LU ;setup start time for bingo
DO NOW^%DTC
SET TM=$EXTRACT(%,1,12)
SET TM1=$PIECE(TM,".",2)
+1 KILL SUSROUTE,BBRX,RXP,RXFL,RXRP,RXPR,RXRR
+2 KILL PSOPROFL,PSOE,RXP1,RXPR,PRF,PSOWIN,PSOWINEN
SET MW=""
WRITE !
SET DIR("A")="Select SUSPENDED Rx #: "
SET DIR(0)="FOA"
SET DIR("?")="Enter the Rx # or wand the barcode. For a list of suspense prescriptions, type '??'"
SET DIR("??")="^D LIST^PSOSUPRX"
+3 SET POP=0
DO ^DIR
KILL DIR
if $DATA(DIRUT)!('Y)
GOTO ST
SET OUT=0
if Y["-"
DO PSOINST^PSOSUPAT
if OUT
GOTO LU
+4 if Y'["-"
SET X=Y
if Y["-"
SET Y=$PIECE(Y,"-",2)
SET X=$PIECE(^PSRX(+Y,0),"^")
KILL Y
if $GET(X)=""
GOTO ST
KILL DIC
WRITE !
Begin DoDot:1
+5 SET PSOSPINT=X
SET DIC("S")="I $D(^PSRX(+$P(^PS(52.5,+Y,0),""^""),0)),$P($G(^(""STA"")),""^"")=5,$P($G(^(0)),""^"")=PSOSPINT"
End DoDot:1
SET DIC="^PS(52.5,"
SET DIC(0)="ZQE"
DO ^DIC
KILL DIC,PSOSPINT
WRITE !
if $DATA(DTOUT)!($DATA(DUOUT))
GOTO ST
if Y<0
GOTO LU
SET RXREC=+Y(0)
SET SFN=+Y
+6 SET PSOPLLRX=$GET(RXREC)
IF PSOPLLRX
DO PSOL^PSSLOCK(PSOPLLRX)
IF '$GET(PSOMSG)
Begin DoDot:1
+7 IF $PIECE($GET(PSOMSG),"^",2)'=""
WRITE !,$PIECE($GET(PSOMSG),"^",2),!
QUIT
+8 WRITE !,"Another person is editing this order.",!
End DoDot:1
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to continue"
DO ^DIR
KILL DIR
KILL PSOMSG,PSOPLLRX,X,Y
GOTO LU
+9 KILL PSOMSG
+10 SET PSOLOUD=1
if $PIECE($GET(^PS(55,$PIECE(Y(0),"^",3),0)),"^",6)'=2
DO EN^PSOHLUP($PIECE(Y(0),"^",3))
KILL PSOLOUD
+11 IF $GET(PSODIV)
IF $PIECE($GET(^PS(52.5,SFN,0)),"^",6)'=$GET(PSOSITE)
SET PSPOP=0
SET PSOSAV=Y
SET PSOSAVO=Y(0)
DO CKDIV^PSOSUPAT
SET Y=PSOSAV
SET Y(0)=PSOSAVO
KILL PSOSAV,PSOSAVO,PSOPRFLG
if PSPOP
DO UNLK
if PSPOP
GOTO LU
+12 DO CHKDEAD
if DEAD
WRITE !!,?10,$GET(PSDNAME)," DIED ",$GET(PSDDDATE)
if 'DEAD
DO BEG
if $GET(PSOQFLAG)
DO RESET^PSOSUPAT
KILL PSOQFLAG,PSOPULL
DO UNLK
GOTO LU
EXIT KILL ASKED,CBD,CNT,COM,DA,DEAD,DEL,DFN,DIRUT,DR,DTOUT,DUOUT,HOLDDFN,HDSFN,JJ,MW,OLD,OUT,PDUZ,PSODFN,TM,TM1,RXLTOP,RXRR,PSOGET,PSOGETF,PSOGETFN
+1 KILL PPL,PSOPULL,PSOWIN,PSOWINEN,PRF,PSODBQ,PSPOP,PSOQFLAG,PSOPROFL,RF,RFCNT,RX,RXP1,RXPR,RXREC,SA,SFN,STOP,SUSPT,VADM,ZTSK,RXFL
+2 KILL X,Y,Z,PSOPRFLG,PSDDDATE,PSDNAME,ZZZZ,RXRP
QUIT
CHKDEAD SET (DFN,PSODFN)=+$PIECE(Y(0),"^",3)
DO DEM^VADPT
SET PSDNAME=$GET(VADM(1))
IF VADM(1)=""
WRITE !?10,"PATIENT UNKNOWN"
SET DEAD=0
QUIT
+1 IF VADM(6)=""
SET DEAD=0
QUIT
+2 SET PSDDDATE=$PIECE(VADM(6),"^",2)
SET (PDUZ,PSOCLC)=DUZ
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
DEAD SET HOLD=DA
SET REA="C"
SET COM="Died ("_$GET(PSDDDATE)_")"
SET DA=RXREC
SET DEAD=1
DO CAN^PSOCAN
SET DA=HOLD
KILL HOLD,REA
QUIT
BEG SET PDUZ=DUZ
IF +$GET(^PS(52.5,SFN,"P"))
WRITE !,">>> Rx #",$PIECE(^PSRX(+$PIECE(^(0),"^"),0),"^")," ALREADY PRINTED FROM SUSPENSE.",!,?5,"USE THE REPRINT OPTION TO REPRINT LABEL.",!
QUIT
+1 IF +$PIECE($GET(^PSRX(RXREC,2)),"^",6)<DT
IF +$PIECE($GET(^("STA")),"^")<11
Begin DoDot:1
+2 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!"
FOR PSOE=1:1:3
WRITE "."
HANG 1
+3 IF '$DATA(^PS(52.5,SFN,0))
KILL PSOE
QUIT
+4 ;
+5 ; PSO*7*427 - 7/24/2015
+6 ; Check if Label Log indicates a label was already printed. If it does, ask the user if they still
+7 ; want to print. If they don't, remove from Suspense queue, then quit.
+8 NEW PRNTED,REFILL
+9 SET REFILL=$PIECE($GET(^PS(52.5,SFN,0)),"^",13)
+10 SET PRNTED=$$PRINTED^PSOSULBL(SFN,RXREC,REFILL)
+11 IF PRNTED
NEW CONT
SET CONT=$$PRTQUES(RXREC,REFILL)
IF CONT'=1
Begin DoDot:1
+12 IF CONT=0
DO REMOVE^PSOSULBL(SFN,RXREC,REFILL,DUZ,1,PRNTED)
+13 IF CONT=-1
WRITE !,"This prescription will not be pulled but will be left on suspense."
End DoDot:1
QUIT
+14 ;
+15 DO ICN^PSODPT(+$PIECE(^PSRX(RXREC,0),"^",2))
+16 SET RXFL(RXREC)=$PIECE($GET(^PS(52.5,SFN,0)),"^",13)
+17 SET HDSFN=SFN
SET (PPL,DA)=RXREC
if $PIECE(^PS(52.5,SFN,0),"^",5)
SET (RXP1,RXPR(RXREC))=$PIECE(^(0),"^",5)
+18 if $PIECE(^PS(52.5,SFN,0),"^",12)
SET RXRP(RXREC)=1
DO QUES
if $GET(PSOQFLAG)
QUIT
+19 SET (PSOPULL,PSODBQ,PSONOPRT)=1
SET RXLTOP=1
DO WIND
DO Q^PSORXL
SET PPL=RXREC
+20 IF '$GET(PSOQFLAG)
WRITE !!,"LABEL QUEUED TO PRINT",!
KILL RX
+21 IF '$GET(PSOQFLAG)
DO PRF
if '$GET(PSOQFLAG)
Begin DoDot:1
+22 if '$GET(PSOPROFL)
SET PSOPRFLG=1
if $GET(PSOPROFL)
WRITE !!,"PROFILE QUEUED TO PRINT"
End DoDot:1
SET PSOQFLAG=0
+23 KILL PSONOPRT,RXPR,RXP1
+24 SET PPL=RXREC
+25 ;call to bingo board
+26 if $GET(SUSROUTE)
SET BBRX(1)=PPL
+27 if $GET(BINGRTE)&($DATA(DISGROUP))&('$GET(PSOQFLAG))
DO ^PSOBING1
KILL BINGRTE,BBRX
+28 QUIT
+29 ; PSO*427-DMB-7/27/2015. PSOSUPAT (Pull Early for all Rx for a patient) used to call QUES. Because of that, the code below
+30 ; had checks to make sure that Routing, Method of P/U, and Pull Rx question was only asked for the first Rx. Now that PSOSUPAT
+31 ; no longer calls QUES, those checks/variables were removed.
QUES ;
+1 ; Ask Routing, method of pickup, and whether to continue. Also update RX and RX Suspense records with new values. Save off old
+2 ; values in case we need to reset them later.
+3 WRITE !
KILL DIR
SET DIR("A")="Select routing for Rx(s)"
SET DIR(0)="S^M:MAIL;W:WINDOW"
SET DIR("B")="WINDOW"
DO ^DIR
KILL DIR
SET MW=Y
IF Y["^"!($DATA(DTOUT))
WRITE !!?5,"Nothing pulled from suspense!",!
SET PSOQFLAG=1
QUIT
+4 SET PSOGET="M"
DO GETMW^PSOSUPOE
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")
+5 if $GET(MW)="W"
SET SUSROUTE=1
SET $PIECE(^PS(52.5,SFN,0),"^",4)=$GET(MW)
if $GET(MW)="W"
Begin DoDot:1
+6 IF $PIECE(PSOPAR,"^",12)
SET DA=RXREC
SET DIE="^PSRX("
SET DR=35
DO ^DIE
if $DATA(Y)!($DATA(DTOUT))
SET PSOQFLAG=1
if $GET(PSOQFLAG)
QUIT
SET PSOWIN=1
SET PSOWINEN=$PIECE($GET(^PSRX(RXREC,"MP")),"^")
QUIT
End DoDot:1
if $GET(PSOQFLAG)
QUIT
DO MAIL^PSOSUPAT
+7 WRITE !!
SET DIR("A")="Pull Rx(s) and delete from suspense"
SET DIR("B")="Y"
SET DIR(0)="Y"
Begin DoDot:1
+8 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"
+9 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."
End DoDot:1
DO ^DIR
KILL DIR
IF Y'=1
WRITE $CHAR(7),!!?5,"Nothing pulled from suspense!",!
SET PSOQFLAG=1
QUIT
+10 SET HDSFN=SFN
+11 ;
+12 ; - Submitting Rx to ECME for 3rd Party Billing
+13 NEW RFL
SET RFL=RXFL(RXREC)
IF RFL=""
SET RFL=$$LSTRFL^PSOBPSU1(RXREC)
+14 ;
+15 ; Do not send a claim if the last submission was rejected and
+16 ; all rejects have been closed.
+17 ;
+18 IF '$$SEND^PSOBPSU2(RXREC,RFL)
QUIT
+19 ;
+20 DO ECMESND^PSOBPSU1(RXREC,RFL,,"PE")
+21 ; Quit if there is an unresolved TRICARE/CHAMPVA non-billable reject code, PSO*7*358
+22 IF $$PSOET^PSOREJP3(RXREC,RFL)
SET PSOQFLAG=1
QUIT
+23 NEW PSOTRIC
SET PSOTRIC=""
SET PSOTRIC=$$TRIC^PSOREJP1(RXREC,RFL,.PSOTRIC)
+24 IF $$FIND^PSOREJUT(RXREC,RFL)
IF $$HDLG^PSOREJU1(RXREC,RFL,"79,88,943","PE","IOQ","I")="Q"
SET PSOQFLAG=1
QUIT
+25 ;No label if discontinued via Reject Notification screen
IF $PIECE($GET(^PSRX(RXREC,"STA")),"^")=12
SET PSOQFLAG=1
QUIT
+26 ;
+27 QUIT
PRF if '$DATA(DFN)
SET DFN=+$PIECE(^PS(52.5,SFN,0),"^",3)
IF $PIECE(PSOPAR,"^",8)
IF '$DATA(^PSRX(RXREC,1))
IF '$DATA(PRF(DFN))
IF '$GET(RXP1)
SET PSOPROFL=1
SET HOLDDFN=DFN
DO ^PSOPRF
SET DFN=HOLDDFN
KILL HOLDDFN
SET PRF(DFN)=""
+1 QUIT
LIST SET X="?"
SET DIC("S")="I $D(^PSRX(+$P(^PS(52.5,+Y,0),""^""),0)),$P($G(^(""STA"")),""^"")=5"
SET DIC="^PS(52.5,"
SET DIC(0)="ZQ"
DO ^DIC
KILL DIC
WRITE !
if Y<0!($DATA(DTOUT))
QUIT
QUIT
NEXT SET PSOX("IRXN")=RX
DO NEXT^PSOUTIL(.PSOX)
SET NEXT=$PIECE(PSOX("RX3"),"^",2)
+1 SET DA=RX
SET DIE=52
SET DR="102///"_NEXT
DO ^DIE
KILL DIE
if $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+2 KILL NEXT,PSOX
QUIT
WIND ;
+1 NEW RRT,RRTT,XXXX,JJJJ,PSINTRX,RTETEST,PSOPSO,SSSS
+2 SET BINGRTE=0
+3 SET RRT=1
FOR XXXX=1:1:$LENGTH(PPL)
SET RRTT=$EXTRACT(PPL,XXXX)
IF RRTT=","
SET RRT=RRT+1
+4 FOR JJJJ=1:1:RRT
if $GET(BINGRTE)
QUIT
SET PSINTRX=$PIECE(PPL,",",JJJJ)
IF $DATA(^PSRX(+PSINTRX,0))
Begin DoDot:1
+5 IF $GET(RXPR(PSINTRX))
SET RTETEST=$PIECE($GET(^PSRX(PSINTRX,"P",RXPR(PSINTRX),0)),"^",2)
if RTETEST="W"
SET BINGRTE=1
QUIT
+6 SET PSOPSO=0
FOR SSSS=0:0
SET SSSS=$ORDER(^PSRX(PSINTRX,1,SSSS))
if 'SSSS
QUIT
SET PSOPSO=SSSS
+7 IF 'PSOPSO
SET RTETEST=$PIECE($GET(^PSRX(PSINTRX,0)),"^",11)
if RTETEST="W"
SET BINGRTE=1
QUIT
+8 IF PSOPSO
SET RTETEST=$PIECE($GET(^PSRX(PSINTRX,1,PSOPSO,0)),"^",2)
if RTETEST="W"
SET BINGRTE=1
QUIT
End DoDot:1
+9 QUIT
UNLK ;Unlock prescription
+1 if '$GET(PSOPLLRX)
QUIT
+2 DO PSOUL^PSSLOCK(PSOPLLRX)
+3 KILL PSOPLLRX
+4 QUIT
+5 ;
PRTQUES(RX,RFL) ;
+1 ; Prompt if the user wants to continue when a label has been printed already
+2 ; Input:
+3 ; RX - Prescription (#52) file IEN
+4 ; RFL - Fill Number
+5 ; Output:
+6 ; 0 - Do not continue (user said No)
+7 ; 1 - Continue (user said Yes)
+8 ; -1 - Up-arrow, time-out, invalid parameter or any other non-YES/NO response
+9 ;
+10 IF '$GET(RX)
QUIT -1
+11 IF $GET(RFL)=""
SET RFL=$$LSTRFL^PSOBPSU1(RX)
+12 ;
+13 NEW DIR,Y,DIRUT,DTOUT,DIRUT,DIROUT
+14 WRITE !!,"Label for Rx#",$PIECE($GET(^PSRX(RX,0)),"^")," Fill#",RFL," has already been printed"
+15 SET DIR(0)="Y"
SET DIR("A")="Do you want to continue"
SET DIR("B")="No"
+16 DO ^DIR
+17 IF Y=0
QUIT 0
+18 IF Y=1
QUIT 1
+19 QUIT -1
