PSOORFI6 ;BIR/SJA-finish cprs orders cont. ;01/05/07
;;7.0;OUTPATIENT PHARMACY;**225**;DEC 1997;Build 29
;External reference to ^PSDRUG supported by DBIA 221
;External references PSOL, and PSOUL^PSSLOCK supported by DBIA 2789
;External reference to ^DPT supported by DBIA 10035
;
DC N ACTION,LST,PSI,PSODFLG,PSONOORS,PSOOPT
N VALMCNT W ! K DIR,DUOUT,DIROUT,DTOUT,PSOELSE
I '$G(PSOERR("DEAD")) S PSOELSE=1 D PDATA Q:$D(DUOUT)!$D(DTOUT) D Q:$D(DIRUT)
.D NOOR^PSOCAN4 Q:$D(DIRUT)
.S DIR("A")="Comments",DIR(0)="F^10:75",DIR("B")="Per Pharmacy Request" D ^DIR K DIR
I '$G(PSOELSE) K PSOELSE S PSONOOR="A" D DE^PSOORFI2 I '$G(ACTION)!('$D(PSODFLG)) S VALMBCK="R" Q
K PSOELSE I $D(DIRUT) K DIRUT,DUOUT,DTOUT,Y Q
S ACOM=Y
S INCOM=ACOM,PSONOORS=PSONOOR D DE^PSOORFI2
I '$G(ACTION)!('$D(PSODFLG)) Q
S PSONOOR=PSONOORS D RTEST D SPEED D ULP^PSOCAN
K PSOCAN,ACOM,INCOM,ACTION,LINE,PSONOOR,PSOSDXY,PSONOORS,PSOOPT,RXCNT,REA,RX,PSODA,DRG
S Y=-1
Q
PSPEED S (YY,PSODA)=$P(PSOSD(STA,DRG),"^"),RX=$P($G(^PSRX(PSODA,0)),"^") D SPEED1 Q:PSPOP!($D(PSINV(RX)))
Q:$G(SPEED)&(REA="R")
SHOW S DRG=+$P(^PSRX(PSODA,0),"^",6),DRG=$S($D(^PSDRUG(DRG,0)):$P(^(0),"^"),1:"")
S LC=0 W !,$P(^PSRX(PSODA,0),"^")," ",DRG,?52,$S($D(^DPT(+$P(^PSRX(PSODA,0),"^",2),0)):$P(^(0),"^"),1:"PATIENT UNKNOWN")
I REA="C" W !?25,"Rx to be Discontinued",! Q
W !?21,"*** Rx to be Reinstated ***",!
Q
SPEED1 S PSPOP=0 I $G(PSODIV),+$P($G(^PSRX(PSODA,2)),"^",9)'=$G(PSOSITE) D:'$G(SPEED) DIV^PSOCAN
K STAT S STAT=+$P(^PSRX(PSODA,"STA"),"^"),REA=$E("C00CCCCCCCCCR000C",STAT+1)
Q:$G(SPEED)&(REA="R")
I REA="R",$P($G(^PSRX(PSODA,"PKI")),"^") S PKI=1 S PSINV(RX)="" Q
I REA=0!(PSPOP)!($P(^PSRX(+YY,"STA"),"^")>12),$P(^("STA"),"^")<16 S PSINV(RX)="" Q
S:REA'=0&('PSPOP) PSCAN(RX)=PSODA_"^"_REA,RXCNT=$G(RXCNT)+1
Q
SPEED N PKI K PSINV,PSCAN S PSODA=IN I $D(^PSRX(PSODA,0)) S YY=PSODA,RX=$P(^(0),"^") S:PSODA<0 PSINV(RX)="" D:PSODA>0 SPEED1
G:'$D(PSCAN) INVALD S II="",RXCNT=0 F S II=$O(PSCAN(II)) Q:II="" S PSODA=+PSCAN(II),REA=$P(PSCAN(II),"^",2),RXCNT=RXCNT+1 D SHOW
;
ASK G:'$D(PSCAN) INVALD W ! S DIR("A")="OK to "_$S($G(RXCNT)>1:"Change Status",REA="C":"Discontinue the active order",1:"Reinstate"),DIR(0)="Y",DIR("B")="N"
D ^DIR K DIR I $D(DIRUT) S:$O(PSOSDX(0)) PSOSDXY=1 Q
I 'Y S:$O(PSOSDX(0)) PSOSDXY=1 K PSCAN D INVALD Q
S RX="" F S RX=$O(PSCAN(RX)) Q:RX="" D PSOL^PSSLOCK(+PSCAN(RX)) I $G(PSOMSG) D ACT D PSOUL^PSSLOCK(+PSCAN(RX))
D INVALD
Q
ACT S DA=+PSCAN(RX),REA=$P(PSCAN(RX),"^",2),II=RX,PSODFN=$P(^PSRX(DA,0),"^",2) I REA="R" D REINS^PSOCAN2 Q
S PSOOPT=-1 D CAN^PSOCAN
Q
INVALD K PSCAN Q:'$D(PSINV) W !! F I=1:1:80 W "="
W $C(7),!!,"The Following Rx Number(s) Are Invalid Choices, Expired, "_$S($G(PKI):"Digitally Signed",1:""),!,"Discontinued by Provider, or Marked As Deleted:" S II="" F S II=$O(PSINV(II)) Q:II="" W !?10,II
K PSINV I $G(PSOERR)!($G(SPEED)) K DIR,DUOUT,DTOUT,DIRUT S DIR(0)="E",DIR("A")="Press Return to Continue"
D ^DIR K DIR,DTOUT,DIRUT,DUOUT
KILL D KILL^PSOCAN2
K PSOMSG,PSOPLCK,PSOWUN,PSOULRX
Q
RTEST ;
Q:'$G(LINE)
N PCIN,PCINFLAG,PCINX
S PCINFLAG=0 F PCIN=1:1 S PCINX=$P(LINE,",",PCIN) Q:$P(LINE,",",PCIN)']"" D
.Q:'$G(PCINX)
.Q:'$G(PSOCAN(PCINX))
.I $P($G(^PSRX(+$G(PSOCAN(PCINX)),"STA")),"^")'=12,'$G(PCINFLAG) S PSOCANRD=+$P($G(^PSRX($G(PSOCAN(PCINX)),0)),"^",4) S PCINFLAG=1
I '$G(PCINFLAG) S PSOCANRZ=1
Q
RTESTA ;
N PFIN,PFINZ,PFINFLAG
S PFINFLAG=0 S PFIN="" F S PFIN=$O(PSOSD(PFIN)) Q:PFIN="" S PFINZ="" F S PFINZ=$O(PSOSD(PFIN,PFINZ)) Q:PFINZ="" D
.I $G(PFIN)'="PENDING" I $P($G(^PSRX(+$P($G(PSOSD(PFIN,PFINZ)),"^"),"STA")),"^")'=12,'$G(PFINFLAG) S PSOCANRD=+$P($G(^(0)),"^",4),PFINFLAG=1
I '$G(PFINFLAG) S PSOCANRZ=1
Q
PDATA Q:$P(^PS(52.41,ORD,0),"^",3)'="RNW"!('$P(^PS(52.41,ORD,0),"^",21))
S PSI=0,IN=0 F S PSI=$O(PSOLST(PSI)) Q:'PSI!(IN) I $P(PSOLST(PSI),"^",2)=$P(^PS(52.41,ORD,0),"^",21) S LINE=PSI,(PSOCAN(PSI),IN)=$P(PSOLST(PSI),"^",2)
Q:'$G(LINE)
S:(+$G(^PSRX($P(^PS(52.41,ORD,0),"^",21),"STA"))<9) PSODFLG=1 Q:'$G(PSODFLG)
D ASKDC S ACTION=Y
Q
ASKDC W ! K DIR,DUOUT,DIRUT,DTOUT
S DIR("A")="There is an active Rx for this pending order, Discontinue both (Y/N)",DIR("B")="NO",DIR(0)="Y"
S DIR("?",1)="Y - Discontinue both pending and active Rx",DIR("?",2)="N - Discontinue pending order only"
S DIR("?")="'^' - Quit (no action taken)" D ^DIR K DIR Q
PSOORFI6 ;BIR/SJA-finish cprs orders cont. ;01/05/07
+1 ;;7.0;OUTPATIENT PHARMACY;**225**;DEC 1997;Build 29
+2 ;External reference to ^PSDRUG supported by DBIA 221
+3 ;External references PSOL, and PSOUL^PSSLOCK supported by DBIA 2789
+4 ;External reference to ^DPT supported by DBIA 10035
+5 ;
DC NEW ACTION,LST,PSI,PSODFLG,PSONOORS,PSOOPT
+1 NEW VALMCNT
WRITE !
KILL DIR,DUOUT,DIROUT,DTOUT,PSOELSE
+2 IF '$GET(PSOERR("DEAD"))
SET PSOELSE=1
DO PDATA
IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT
Begin DoDot:1
+3 DO NOOR^PSOCAN4
IF $DATA(DIRUT)
QUIT
+4 SET DIR("A")="Comments"
SET DIR(0)="F^10:75"
SET DIR("B")="Per Pharmacy Request"
DO ^DIR
KILL DIR
End DoDot:1
IF $DATA(DIRUT)
QUIT
+5 IF '$GET(PSOELSE)
KILL PSOELSE
SET PSONOOR="A"
DO DE^PSOORFI2
IF '$GET(ACTION)!('$DATA(PSODFLG))
SET VALMBCK="R"
QUIT
+6 KILL PSOELSE
IF $DATA(DIRUT)
KILL DIRUT,DUOUT,DTOUT,Y
QUIT
+7 SET ACOM=Y
+8 SET INCOM=ACOM
SET PSONOORS=PSONOOR
DO DE^PSOORFI2
+9 IF '$GET(ACTION)!('$DATA(PSODFLG))
QUIT
+10 SET PSONOOR=PSONOORS
DO RTEST
DO SPEED
DO ULP^PSOCAN
+11 KILL PSOCAN,ACOM,INCOM,ACTION,LINE,PSONOOR,PSOSDXY,PSONOORS,PSOOPT,RXCNT,REA,RX,PSODA,DRG
+12 SET Y=-1
+13 QUIT
PSPEED SET (YY,PSODA)=$PIECE(PSOSD(STA,DRG),"^")
SET RX=$PIECE($GET(^PSRX(PSODA,0)),"^")
DO SPEED1
IF PSPOP!($DATA(PSINV(RX)))
QUIT
+1 IF $GET(SPEED)&(REA="R")
QUIT
SHOW SET DRG=+$PIECE(^PSRX(PSODA,0),"^",6)
SET DRG=$SELECT($DATA(^PSDRUG(DRG,0)):$PIECE(^(0),"^"),1:"")
+1 SET LC=0
WRITE !,$PIECE(^PSRX(PSODA,0),"^")," ",DRG,?52,$SELECT($DATA(^DPT(+$PIECE(^PSRX(PSODA,0),"^",2),0)):$PIECE(^(0),"^"),1:"PATIENT UNKNOWN")
+2 IF REA="C"
WRITE !?25,"Rx to be Discontinued",!
QUIT
+3 WRITE !?21,"*** Rx to be Reinstated ***",!
+4 QUIT
SPEED1 SET PSPOP=0
IF $GET(PSODIV)
IF +$PIECE($GET(^PSRX(PSODA,2)),"^",9)'=$GET(PSOSITE)
IF '$GET(SPEED)
DO DIV^PSOCAN
+1 KILL STAT
SET STAT=+$PIECE(^PSRX(PSODA,"STA"),"^")
SET REA=$EXTRACT("C00CCCCCCCCCR000C",STAT+1)
+2 IF $GET(SPEED)&(REA="R")
QUIT
+3 IF REA="R"
IF $PIECE($GET(^PSRX(PSODA,"PKI")),"^")
SET PKI=1
SET PSINV(RX)=""
QUIT
+4 IF REA=0!(PSPOP)!($PIECE(^PSRX(+YY,"STA"),"^")>12)
IF $PIECE(^("STA"),"^")<16
SET PSINV(RX)=""
QUIT
+5 IF REA'=0&('PSPOP)
SET PSCAN(RX)=PSODA_"^"_REA
SET RXCNT=$GET(RXCNT)+1
+6 QUIT
SPEED NEW PKI
KILL PSINV,PSCAN
SET PSODA=IN
IF $DATA(^PSRX(PSODA,0))
SET YY=PSODA
SET RX=$PIECE(^(0),"^")
IF PSODA<0
SET PSINV(RX)=""
IF PSODA>0
DO SPEED1
+1 IF '$DATA(PSCAN)
GOTO INVALD
SET II=""
SET RXCNT=0
FOR
SET II=$ORDER(PSCAN(II))
IF II=""
QUIT
SET PSODA=+PSCAN(II)
SET REA=$PIECE(PSCAN(II),"^",2)
SET RXCNT=RXCNT+1
DO SHOW
+2 ;
ASK IF '$DATA(PSCAN)
GOTO INVALD
WRITE !
SET DIR("A")="OK to "_$SELECT($GET(RXCNT)>1:"Change Status",REA="C":"Discontinue the active order",1:"Reinstate")
SET DIR(0)="Y"
SET DIR("B")="N"
+1 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
IF $ORDER(PSOSDX(0))
SET PSOSDXY=1
QUIT
+2 IF 'Y
IF $ORDER(PSOSDX(0))
SET PSOSDXY=1
KILL PSCAN
DO INVALD
QUIT
+3 SET RX=""
FOR
SET RX=$ORDER(PSCAN(RX))
IF RX=""
QUIT
DO PSOL^PSSLOCK(+PSCAN(RX))
IF $GET(PSOMSG)
DO ACT
DO PSOUL^PSSLOCK(+PSCAN(RX))
+4 DO INVALD
+5 QUIT
ACT SET DA=+PSCAN(RX)
SET REA=$PIECE(PSCAN(RX),"^",2)
SET II=RX
SET PSODFN=$PIECE(^PSRX(DA,0),"^",2)
IF REA="R"
DO REINS^PSOCAN2
QUIT
+1 SET PSOOPT=-1
DO CAN^PSOCAN
+2 QUIT
INVALD KILL PSCAN
IF '$DATA(PSINV)
QUIT
WRITE !!
FOR I=1:1:80
WRITE "="
+1 WRITE $CHAR(7),!!,"The Following Rx Number(s) Are Invalid Choices, Expired, "_$SELECT($GET(PKI):"Digitally Signed",1:""),!,"Discontinued by Provider, or Marked As Deleted:"
SET II=""
FOR
SET II=$ORDER(PSINV(II))
IF II=""
QUIT
WRITE !?10,II
+2 KILL PSINV
IF $GET(PSOERR)!($GET(SPEED))
KILL DIR,DUOUT,DTOUT,DIRUT
SET DIR(0)="E"
SET DIR("A")="Press Return to Continue"
+3 DO ^DIR
KILL DIR,DTOUT,DIRUT,DUOUT
KILL DO KILL^PSOCAN2
+1 KILL PSOMSG,PSOPLCK,PSOWUN,PSOULRX
+2 QUIT
RTEST ;
+1 IF '$GET(LINE)
QUIT
+2 NEW PCIN,PCINFLAG,PCINX
+3 SET PCINFLAG=0
FOR PCIN=1:1
SET PCINX=$PIECE(LINE,",",PCIN)
IF $PIECE(LINE,",",PCIN)']""
QUIT
Begin DoDot:1
+4 IF '$GET(PCINX)
QUIT
+5 IF '$GET(PSOCAN(PCINX))
QUIT
+6 IF $PIECE($GET(^PSRX(+$GET(PSOCAN(PCINX)),"STA")),"^")'=12
IF '$GET(PCINFLAG)
SET PSOCANRD=+$PIECE($GET(^PSRX($GET(PSOCAN(PCINX)),0)),"^",4)
SET PCINFLAG=1
End DoDot:1
+7 IF '$GET(PCINFLAG)
SET PSOCANRZ=1
+8 QUIT
RTESTA ;
+1 NEW PFIN,PFINZ,PFINFLAG
+2 SET PFINFLAG=0
SET PFIN=""
FOR
SET PFIN=$ORDER(PSOSD(PFIN))
IF PFIN=""
QUIT
SET PFINZ=""
FOR
SET PFINZ=$ORDER(PSOSD(PFIN,PFINZ))
IF PFINZ=""
QUIT
Begin DoDot:1
+3 IF $GET(PFIN)'="PENDING"
IF $PIECE($GET(^PSRX(+$PIECE($GET(PSOSD(PFIN,PFINZ)),"^"),"STA")),"^")'=12
IF '$GET(PFINFLAG)
SET PSOCANRD=+$PIECE($GET(^(0)),"^",4)
SET PFINFLAG=1
End DoDot:1
+4 IF '$GET(PFINFLAG)
SET PSOCANRZ=1
+5 QUIT
PDATA IF $PIECE(^PS(52.41,ORD,0),"^",3)'="RNW"!('$PIECE(^PS(52.41,ORD,0),"^",21))
QUIT
+1 SET PSI=0
SET IN=0
FOR
SET PSI=$ORDER(PSOLST(PSI))
IF 'PSI!(IN)
QUIT
IF $PIECE(PSOLST(PSI),"^",2)=$PIECE(^PS(52.41,ORD,0),"^",21)
SET LINE=PSI
SET (PSOCAN(PSI),IN)=$PIECE(PSOLST(PSI),"^",2)
+2 IF '$GET(LINE)
QUIT
+3 IF (+$GET(^PSRX($PIECE(^PS(52.41,ORD,0),"^",21),"STA"))<9)
SET PSODFLG=1
IF '$GET(PSODFLG)
QUIT
+4 DO ASKDC
SET ACTION=Y
+5 QUIT
ASKDC WRITE !
KILL DIR,DUOUT,DIRUT,DTOUT
+1 SET DIR("A")="There is an active Rx for this pending order, Discontinue both (Y/N)"
SET DIR("B")="NO"
SET DIR(0)="Y"
+2 SET DIR("?",1)="Y - Discontinue both pending and active Rx"
SET DIR("?",2)="N - Discontinue pending order only"
+3 SET DIR("?")="'^' - Quit (no action taken)"
DO ^DIR
KILL DIR
QUIT
