PSOORFI6.m

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