PSONEW2 ;IHS/DSD/JCM - displays new rx information for edit ;29-May-2012 14:55;PLS
;;7.0;OUTPATIENT PHARMACY;**32,37,46,71,94,124,139,157,1005,1006,1009,1013,143,226,237,239,225,1015**;DEC 1997;Build 62
;External reference to ^PSDRUG supported by DBIA 221
;External reference to ^DPT supported by DBIA 10035
;External reference to PSOUL^PSSLOCK supported by DBIA 2789
;External reference VADPT supported by DBIA 10061
; This routine displays the entered new rx information and
; asks if correct, if not allows editing of the data.
;------------------------------------------------------------
;PSO*237 issue expired error message
;
; Modified - IHS/CIA/PLS - 01/02/04 - EP, EN1+2 and DISPLAY+3
; - IHS/MSC/PLS - 10/05/07 - Line RX52 - added call to APSPFNC3
; 09/27/10 - Line RX52+1 Added call to KILLOCM^PSORN52
; 10/19/10 - Added RX52E line tag
; 02/13/12 - Line STOP+2
EP ; IHS/CIA/PLS - 01/02/04 - Check for DUE Questionnarie
;N APFLAG S APFLAG="N" D ^APSPQ ; PLS 06/21/04 COMMENTED OUT
START ;
S (PSONEW("DFLG"),PSONEW2("QFLG"))=0
D STOP
D DISPLAY ; Displays information
;Copay exemption checks
D SCP^PSORN52D
S PSONEWFF=1,PSOFLAG=1 K PSOANSQ,PSOANSQD S PSOCPZ("DFLG")=0,PSONEW("NEWCOPAY")=0
;can't check PSOSCA for <50 here because of PSOBILL check in PSOCPB
I (PSOSCP<50&($P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)'=1)),$G(DUZ("AG"))="V" D COPAY^PSOCPB W !
I PSOSCA&(PSOSCP>49)!((PSOSCA!(PSOBILL=2))&($P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)=1))!(PSOSCP>49&(PSOBILL=2)) D SC^PSOMLLD2
I $G(PSOCPZ("DFLG")) K PSONEWFF,PSOANSQD,PSOCPZ("DFLG"),PSONEW("NEWCOPAY") S DIRUT="",PSONEW("DFLG")=1 D ASKX G END
;IF MILL BILL, AND COPAY (*******TEST THE COPAY CHECK)
I $$DT^PSOMLLDT D I $G(PSOCPZ("DFLG")) K PSONEWFF,PSOANSQD,PSOANSQ,PSOCPZ("DFLG"),PSONEW("NEWCOPAY") S DIRUT="",PSONEW("DFLG")=1 D ASKX G END
.;New prompts Quit after first '^'
.I $D(PSOIBQS(PSODFN,"CV")) D CV^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("CV"))) K PSONEW("NEWCOPAY")
.I $D(PSOIBQS(PSODFN,"VEH")) D VEH^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("VEH"))) K PSONEW("NEWCOPAY")
.I $D(PSOIBQS(PSODFN,"RAD")) D RAD^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("RAD"))) K PSONEW("NEWCOPAY")
.I $D(PSOIBQS(PSODFN,"PGW")) D PGW^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("PGW"))) K PSONEW("NEWCOPAY")
.I $D(PSOIBQS(PSODFN,"SHAD")) D SHAD^PSOMLLD2 I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("SHAD"))) K PSONEW("NEWCOPAY")
.I $D(PSOIBQS(PSODFN,"MST")) D MST^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("MST"))) K PSONEW("NEWCOPAY")
.I $D(PSOIBQS(PSODFN,"HNC")) D HNC^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("HNC"))) K PSONEW("NEWCOPAY")
K PSOCPZ("DFLG"),PSONEWFF
D ASK K:$G(PSONEW("DFLG")) PSOANSQ G:PSONEW2("QFLG")!PSONEW("DFLG") END
S PSORX("EDIT")=1 D EN^PSOORNE1(.PSONEW),FULL^VALM1 G:$G(PSORX("FN")) END I '$G(PSORX("FN")) S PSONEW("DFLG")=1 K PSOANSQ G END ;D EDIT
G:'$G(PSONEW("DFLG")) START
S PSONEW("QFLG")=1,PSONEW("DFLG")=0
END D EOJ
Q
;------------------------------------------------------------
STOP K PSEXDT,X,%DT S PSON52("QFLG")=0
S X1=PSOID,X2=PSONEW("DAYS SUPPLY")*(PSONEW("# OF REFILLS")+1)\1
;IHS/MSC/PLS - 02/13/2012 - Next four lines commented out
;S X2=$S(PSONEW("DAYS SUPPLY")=X2:X2,+$G(PSONEW("CS")):184,1:366)
;I X2<30 D
;. N % S %=$P($G(PSORX("PATIENT STATUS")),"^"),X2=30
;. S:%?.N %=$P($G(^PS(53,+%,0)),"^") I %["AUTH ABS" S X2=5
S X2=$S(+$G(PSONEW("CS")):184,1:366)
D C^%DTC I PSONEW("FILL DATE")>$P(X,".") S PSEXDT=1_"^"_$P(X,".")
K X1,X2,X,%DT
Q
DISPLAY ;
W !!,"Rx # ",PSONEW("RX #")
W ?23,$E(PSONEW("FILL DATE"),4,5),"/",$E(PSONEW("FILL DATE"),6,7),"/",$E(PSONEW("FILL DATE"),2,3),!,$G(PSORX("NAME")),?30,"#",PSONEW("QTY")
; IHS/CIA/PLS - 01/02/04 - Output NDC, AWP,Cost and Triplicate
W ?36,"NDC ",$S($G(PSONEW("NDC"))]"":PSONEW("NDC"),1:$G(PSODRUG("NDC")))
I ('$D(IOBON))!('$D(IOBOFF)) S X="IOBON;IOBOFF" D ENDR^%ZISS
W " ("_$S($G(PSONEW("AWP"))]"":PSONEW("AWP"),$G(PSODRUG("AWP"))]"":PSODRUG("AWP"),1:IOBON_"NO AWP"_IOBOFF)_")"
W " ("_$S($G(PSONEW("COST"))]"":PSONEW("COST"),$G(PSODRUG("COST"))]"":PSODRUG("COST"),1:IOBON_"NO COST"_IOBOFF)_")"
W:$G(PSONEW("TRIP"))]"" " TRIPLICATE SERIAL # "_PSONEW("TRIP")
I $G(SIGOK),$O(SIG(0)) D K D G TRN
.F D=0:0 S D=$O(SIG(D)) W !,SIG(D) Q:'$O(SIG(D))
E S X=PSONEW("SIG") D SIGONE^PSOHELP W !,$G(INS1)
TRN ;I $G(PSOPRC) F I=0:0 S I=$O(PRC(I)) Q:'I W !,PRC(I)
W !!,$S($G(PSODRUG("TRADE NAME"))]"":PSODRUG("TRADE NAME"),1:PSODRUG("NAME"))
W !,PSONEW("PROVIDER NAME"),?25,PSORX("CLERK CODE"),!,"# of Refills: ",PSONEW("# OF REFILLS"),!
; IHS/CIA/PLS - 01/02/04 - Output Manufacturer, Lot # and Expiration Date
N EXPDT S EXPDT=$$FMTE^XLFDT($G(PSONEW("EXPIRATION DATE")),"5DZ") S:'$P(EXPDT,"/",2) EXPDT=$P(EXPDT,"/")_"/"_$P(EXPDT,"/",3)
I APSPMAN=1 D
.W !,"Drug Mfg: ",$G(PSONEW("MANUFACTURER")),?35,"Exp Date: ",$G(EXPDT)
.W ?58,"Lot #: ",$G(PSONEW("LOT #"))
E I APSPMAN=2 D
.W !,?35,"Exp Date: ",$G(EXPDT)
Q
;
ASK ;
K DIR,X,Y S DIR("A")="Is this correct"
S DIR(0)="Y",DIR("B")="YES" D ^DIR K DIR I $D(DIRUT) S PSONEW("DFLG")=1 G ASKX
ASK1 I Y D S PSONEW2("QFLG")=1
.S:$G(PSONEW("MAIL/WINDOW"))["W" BINGCRT=Y,BINGRTE="W"
.D:+$G(PSEXDT)
..S Y=PSONEW("FILL DATE") X ^DD("DD") W !!,$C(7),Y_" fill date is greater than possible expiration date of " S Y=$P(PSEXDT,"^",2) X ^DD("DD") W Y_"."
.D DCORD K RORD,^TMP("PSORXDC",$J)
ASKX I $D(DIRUT) D
.I +$G(PSEXDT) K DIRUT S (PSONEW2("QFLG"),PSONEW2("DFLG"),PSONEW("DFLG"),Y)=1
K X,Y,DIRUT,DTOUT,DUOUT
D:+$G(PSEXDT) PAUSE^VALM1
Q
DCORD ;dc rxs and pending orders after new order is entered
F RORD=0:0 S RORD=$O(^TMP("PSORXDC",$J,RORD)) Q:'RORD D @$S($P(^TMP("PSORXDC",$J,RORD,0),"^")="P":"PEN",1:"RX52")
K RORD
Q
PEN ;pending ^tmp("psorxdc",$j,rord,0)="p^"_rord_"^"_msg
S $P(^PS(52.41,RORD,0),"^",3)="DC",^PS(52.41,RORD,4)=$P(^TMP("PSORXDC",$J,RORD,0),"^",3)
K ^PS(52.41,"AOR",PSODFN,+$P($G(^PS(52.41,RORD,"INI")),"^"),RORD)
D EN^PSOHLSN($P(^PS(52.41,RORD,0),"^"),"OC",$P(^TMP("PSORXDC",$J,RORD,0),"^",3),"D") W $C(7),!," -Pending Order was discontinued..."
D PSOUL^PSSLOCK(RORD_"S") K ^TMP("PSORXDC",$J,RORD,0)
Q
; IHS/MSC/PLS - 10/05/07 - Restructured RX52 to process auto RTS/Delete
RX52 ;rxs in file 52 ^tmp("psorxdc",$j,rord,0)=52^rord^msg^rea^act^sta^dnm^apsprts
I $P(^TMP("PSORXDC",$J,RORD,0),U,9) D KILLOCM^PSORN52(+RORD) G RX52E ;IHS/MSC/PLS - 09/27/10 - Removed chronic med flag
I $P(^TMP("PSORXDC",$J,RORD,0),U,8) D
.D EN^APSPFNC3(RORD)
.W !," -Rx "_$P(^PSRX(RORD,0),"^")_" has been auto RTS/Deleted...",!
E D
.S PSCAN($P(^PSRX(RORD,0),"^"))=RORD_"^"_$P(^TMP("PSORXDC",$J,RORD,0),"^",4)
.S MSG=$P(^TMP("PSORXDC",$J,RORD,0),"^",3),REA=$P(^(0),"^",4),ACT=$P(^(0),"^",5)
.N PSONOOR S PSONOOR="D",DUP=1,DA=RORD D CAN^PSOCAN K PSONOOR
.W !," -Rx "_$P(^PSRX(RORD,0),"^")_" has been discontinued...",!
RX52E K PSOSD($P(^TMP("PSORXDC",$J,RORD,0),"^",6),$P(^TMP("PSORXDC",$J,RORD,0),"^",7))
D PSOUL^PSSLOCK(RORD) K ^TMP("PSORXDC",$J,RORD,0)
Q
;
EDIT ;
S PSORX("EDIT")=1
D ^PSONEW3
S PSONEW("DFLG")=$S($G(PSORX("DFLG")):1,1:0)
Q
;
EOJ ;
K PSONEW2,PSORX("EDIT"),PSORX("DFLG"),PSOEDIT,PSOSCA
Q
;
EN1(PSONEW2) ; Entry point to just display and ask if okay
S PSONEW("DFLG")=0
; IHS/CIA/PLS - 01/06/04 - Set NDC, AWP, and COST array variables
S:$G(PSONEW2("NDC"))]"" PSONEW("NDC")=PSONEW2("NDC")
S:$G(PSONEW2("AWP"))]"" PSONEW("AWP")=PSONEW2("AWP")
S:$G(PSONEW2("COST"))]"" PSONEW("COST")=PSONEW2("COST")
I $G(^PSRX(PSONEW2("IRXN"),0))']"" S PSONEW("DFLG")=1 G EN1X
S PSOX=^PSRX(PSONEW2("IRXN"),0),PSONEW("TRADE NAME")=$G(^("TN")),PSONEW("FILL DATE")=$P($G(^(2)),"^",2)
S PSONEW("RX #")=$P(PSOX,"^"),PSORX("NAME")=$P(^DPT($P(PSOX,"^",2),0),"^")
S PSONEW("QTY")=$P(PSOX,"^",7),PSODRUG("NAME")=$P(^PSDRUG($P(PSOX,"^",6),0),"^"),PSONEW("# OF REFILLS")=$P(PSOX,"^",9)
S PSORX("CLERK CODE")=$P(^VA(200,$P(PSOX,"^",16),0),"^")
S:$G(PSONEW("PROVIDER NAME"))="" PSONEW("PROVIDER NAME")=$P(^VA(200,$P(PSOX,"^",4),0),"^")
S PSONEW("SIG")=$P($G(^PSRX(PSONEW2("IRXN"),"SIG")),"^")
D DISPLAY
D ASK
I PSONEW("DFLG")=1 S PSONEW2("DFLG")=1
EN1X ;
Q
;
EXPR ;Display Expired error message ;PSO*237
S PSONEW("DFLG")=1
W $C(7)
S VALMSG="Order is older than 365 days and can't be finished"
S XQORM("B")="DC"
Q
PSONEW2 ;IHS/DSD/JCM - displays new rx information for edit ;29-May-2012 14:55;PLS
+1 ;;7.0;OUTPATIENT PHARMACY;**32,37,46,71,94,124,139,157,1005,1006,1009,1013,143,226,237,239,225,1015**;DEC 1997;Build 62
+2 ;External reference to ^PSDRUG supported by DBIA 221
+3 ;External reference to ^DPT supported by DBIA 10035
+4 ;External reference to PSOUL^PSSLOCK supported by DBIA 2789
+5 ;External reference VADPT supported by DBIA 10061
+6 ; This routine displays the entered new rx information and
+7 ; asks if correct, if not allows editing of the data.
+8 ;------------------------------------------------------------
+9 ;PSO*237 issue expired error message
+10 ;
+11 ; Modified - IHS/CIA/PLS - 01/02/04 - EP, EN1+2 and DISPLAY+3
+12 ; - IHS/MSC/PLS - 10/05/07 - Line RX52 - added call to APSPFNC3
+13 ; 09/27/10 - Line RX52+1 Added call to KILLOCM^PSORN52
+14 ; 10/19/10 - Added RX52E line tag
+15 ; 02/13/12 - Line STOP+2
EP ; IHS/CIA/PLS - 01/02/04 - Check for DUE Questionnarie
+1 ;N APFLAG S APFLAG="N" D ^APSPQ ; PLS 06/21/04 COMMENTED OUT
START ;
+1 SET (PSONEW("DFLG"),PSONEW2("QFLG"))=0
+2 DO STOP
+3 ; Displays information
DO DISPLAY
+4 ;Copay exemption checks
+5 DO SCP^PSORN52D
+6 SET PSONEWFF=1
SET PSOFLAG=1
KILL PSOANSQ,PSOANSQD
SET PSOCPZ("DFLG")=0
SET PSONEW("NEWCOPAY")=0
+7 ;can't check PSOSCA for <50 here because of PSOBILL check in PSOCPB
+8 IF (PSOSCP<50&($PIECE($GET(^PS(53,+$GET(PSONEW("PATIENT STATUS")),0)),"^",7)'=1))
IF $GET(DUZ("AG"))="V"
DO COPAY^PSOCPB
WRITE !
+9 IF PSOSCA&(PSOSCP>49)!((PSOSCA!(PSOBILL=2))&($PIECE($GET(^PS(53,+$GET(PSONEW("PATIENT STATUS")),0)),"^",7)=1))!(PSOSCP>49&(PSOBILL=2))
DO SC^PSOMLLD2
+10 IF $GET(PSOCPZ("DFLG"))
KILL PSONEWFF,PSOANSQD,PSOCPZ("DFLG"),PSONEW("NEWCOPAY")
SET DIRUT=""
SET PSONEW("DFLG")=1
DO ASKX
GOTO END
+11 ;IF MILL BILL, AND COPAY (*******TEST THE COPAY CHECK)
+12 IF $$DT^PSOMLLDT
Begin DoDot:1
+13 ;New prompts Quit after first '^'
+14 IF $DATA(PSOIBQS(PSODFN,"CV"))
DO CV^PSOMLLDT
IF $GET(PSOCPZ("DFLG"))!($GET(PSOANSQ("CV")))
KILL PSONEW("NEWCOPAY")
+15 IF $DATA(PSOIBQS(PSODFN,"VEH"))
DO VEH^PSOMLLDT
IF $GET(PSOCPZ("DFLG"))!($GET(PSOANSQ("VEH")))
KILL PSONEW("NEWCOPAY")
+16 IF $DATA(PSOIBQS(PSODFN,"RAD"))
DO RAD^PSOMLLDT
IF $GET(PSOCPZ("DFLG"))!($GET(PSOANSQ("RAD")))
KILL PSONEW("NEWCOPAY")
+17 IF $DATA(PSOIBQS(PSODFN,"PGW"))
DO PGW^PSOMLLDT
IF $GET(PSOCPZ("DFLG"))!($GET(PSOANSQ("PGW")))
KILL PSONEW("NEWCOPAY")
+18 IF $DATA(PSOIBQS(PSODFN,"SHAD"))
DO SHAD^PSOMLLD2
IF $GET(PSOCPZ("DFLG"))!($GET(PSOANSQ("SHAD")))
KILL PSONEW("NEWCOPAY")
+19 IF $DATA(PSOIBQS(PSODFN,"MST"))
DO MST^PSOMLLDT
IF $GET(PSOCPZ("DFLG"))!($GET(PSOANSQ("MST")))
KILL PSONEW("NEWCOPAY")
+20 IF $DATA(PSOIBQS(PSODFN,"HNC"))
DO HNC^PSOMLLDT
IF $GET(PSOCPZ("DFLG"))!($GET(PSOANSQ("HNC")))
KILL PSONEW("NEWCOPAY")
End DoDot:1
IF $GET(PSOCPZ("DFLG"))
KILL PSONEWFF,PSOANSQD,PSOANSQ,PSOCPZ("DFLG"),PSONEW("NEWCOPAY")
SET DIRUT=""
SET PSONEW("DFLG")=1
DO ASKX
GOTO END
+21 KILL PSOCPZ("DFLG"),PSONEWFF
+22 DO ASK
IF $GET(PSONEW("DFLG"))
KILL PSOANSQ
IF PSONEW2("QFLG")!PSONEW("DFLG")
GOTO END
+23 ;D EDIT
SET PSORX("EDIT")=1
DO EN^PSOORNE1(.PSONEW)
DO FULL^VALM1
IF $GET(PSORX("FN"))
GOTO END
IF '$GET(PSORX("FN"))
SET PSONEW("DFLG")=1
KILL PSOANSQ
GOTO END
+24 IF '$GET(PSONEW("DFLG"))
GOTO START
+25 SET PSONEW("QFLG")=1
SET PSONEW("DFLG")=0
END DO EOJ
+1 QUIT
+2 ;------------------------------------------------------------
STOP KILL PSEXDT,X,%DT
SET PSON52("QFLG")=0
+1 SET X1=PSOID
SET X2=PSONEW("DAYS SUPPLY")*(PSONEW("# OF REFILLS")+1)\1
+2 ;IHS/MSC/PLS - 02/13/2012 - Next four lines commented out
+3 ;S X2=$S(PSONEW("DAYS SUPPLY")=X2:X2,+$G(PSONEW("CS")):184,1:366)
+4 ;I X2<30 D
+5 ;. N % S %=$P($G(PSORX("PATIENT STATUS")),"^"),X2=30
+6 ;. S:%?.N %=$P($G(^PS(53,+%,0)),"^") I %["AUTH ABS" S X2=5
+7 SET X2=$SELECT(+$GET(PSONEW("CS")):184,1:366)
+8 DO C^%DTC
IF PSONEW("FILL DATE")>$PIECE(X,".")
SET PSEXDT=1_"^"_$PIECE(X,".")
+9 KILL X1,X2,X,%DT
+10 QUIT
DISPLAY ;
+1 WRITE !!,"Rx # ",PSONEW("RX #")
+2 WRITE ?23,$EXTRACT(PSONEW("FILL DATE"),4,5),"/",$EXTRACT(PSONEW("FILL DATE"),6,7),"/",$EXTRACT(PSONEW("FILL DATE"),2,3),!,$GET(PSORX("NAME")),?30,"#",PSONEW("QTY")
+3 ; IHS/CIA/PLS - 01/02/04 - Output NDC, AWP,Cost and Triplicate
+4 WRITE ?36,"NDC ",$SELECT($GET(PSONEW("NDC"))]"":PSONEW("NDC"),1:$GET(PSODRUG("NDC")))
+5 IF ('$DATA(IOBON))!('$DATA(IOBOFF))
SET X="IOBON;IOBOFF"
DO ENDR^%ZISS
+6 WRITE " ("_$SELECT($GET(PSONEW("AWP"))]"":PSONEW("AWP"),$GET(PSODRUG("AWP"))]"":PSODRUG("AWP"),1:IOBON_"NO AWP"_IOBOFF)_")"
+7 WRITE " ("_$SELECT($GET(PSONEW("COST"))]"":PSONEW("COST"),$GET(PSODRUG("COST"))]"":PSODRUG("COST"),1:IOBON_"NO COST"_IOBOFF)_")"
+8 IF $GET(PSONEW("TRIP"))]""
WRITE " TRIPLICATE SERIAL # "_PSONEW("TRIP")
+9 IF $GET(SIGOK)
IF $ORDER(SIG(0))
Begin DoDot:1
+10 FOR D=0:0
SET D=$ORDER(SIG(D))
WRITE !,SIG(D)
IF '$ORDER(SIG(D))
QUIT
End DoDot:1
KILL D
GOTO TRN
+11 IF '$TEST
SET X=PSONEW("SIG")
DO SIGONE^PSOHELP
WRITE !,$GET(INS1)
TRN ;I $G(PSOPRC) F I=0:0 S I=$O(PRC(I)) Q:'I W !,PRC(I)
+1 WRITE !!,$SELECT($GET(PSODRUG("TRADE NAME"))]"":PSODRUG("TRADE NAME"),1:PSODRUG("NAME"))
+2 WRITE !,PSONEW("PROVIDER NAME"),?25,PSORX("CLERK CODE"),!,"# of Refills: ",PSONEW("# OF REFILLS"),!
+3 ; IHS/CIA/PLS - 01/02/04 - Output Manufacturer, Lot # and Expiration Date
+4 NEW EXPDT
SET EXPDT=$$FMTE^XLFDT($GET(PSONEW("EXPIRATION DATE")),"5DZ")
IF '$PIECE(EXPDT,"/",2)
SET EXPDT=$PIECE(EXPDT,"/")_"/"_$PIECE(EXPDT,"/",3)
+5 IF APSPMAN=1
Begin DoDot:1
+6 WRITE !,"Drug Mfg: ",$GET(PSONEW("MANUFACTURER")),?35,"Exp Date: ",$GET(EXPDT)
+7 WRITE ?58,"Lot #: ",$GET(PSONEW("LOT #"))
End DoDot:1
+8 IF '$TEST
IF APSPMAN=2
Begin DoDot:1
+9 WRITE !,?35,"Exp Date: ",$GET(EXPDT)
End DoDot:1
+10 QUIT
+11 ;
ASK ;
+1 KILL DIR,X,Y
SET DIR("A")="Is this correct"
+2 SET DIR(0)="Y"
SET DIR("B")="YES"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET PSONEW("DFLG")=1
GOTO ASKX
ASK1 IF Y
Begin DoDot:1
+1 IF $GET(PSONEW("MAIL/WINDOW"))["W"
SET BINGCRT=Y
SET BINGRTE="W"
+2 IF +$GET(PSEXDT)
Begin DoDot:2
+3 SET Y=PSONEW("FILL DATE")
XECUTE ^DD("DD")
WRITE !!,$CHAR(7),Y_" fill date is greater than possible expiration date of "
SET Y=$PIECE(PSEXDT,"^",2)
XECUTE ^DD("DD")
WRITE Y_"."
End DoDot:2
+4 DO DCORD
KILL RORD,^TMP("PSORXDC",$JOB)
End DoDot:1
SET PSONEW2("QFLG")=1
ASKX IF $DATA(DIRUT)
Begin DoDot:1
+1 IF +$GET(PSEXDT)
KILL DIRUT
SET (PSONEW2("QFLG"),PSONEW2("DFLG"),PSONEW("DFLG"),Y)=1
End DoDot:1
+2 KILL X,Y,DIRUT,DTOUT,DUOUT
+3 IF +$GET(PSEXDT)
DO PAUSE^VALM1
+4 QUIT
DCORD ;dc rxs and pending orders after new order is entered
+1 FOR RORD=0:0
SET RORD=$ORDER(^TMP("PSORXDC",$JOB,RORD))
IF 'RORD
QUIT
DO @$SELECT($PIECE(^TMP("PSORXDC",$JOB,RORD,0),"^")="P":"PEN",1:"RX52")
+2 KILL RORD
+3 QUIT
PEN ;pending ^tmp("psorxdc",$j,rord,0)="p^"_rord_"^"_msg
+1 SET $PIECE(^PS(52.41,RORD,0),"^",3)="DC"
SET ^PS(52.41,RORD,4)=$PIECE(^TMP("PSORXDC",$JOB,RORD,0),"^",3)
+2 KILL ^PS(52.41,"AOR",PSODFN,+$PIECE($GET(^PS(52.41,RORD,"INI")),"^"),RORD)
+3 DO EN^PSOHLSN($PIECE(^PS(52.41,RORD,0),"^"),"OC",$PIECE(^TMP("PSORXDC",$JOB,RORD,0),"^",3),"D")
WRITE $CHAR(7),!," -Pending Order was discontinued..."
+4 DO PSOUL^PSSLOCK(RORD_"S")
KILL ^TMP("PSORXDC",$JOB,RORD,0)
+5 QUIT
+6 ; IHS/MSC/PLS - 10/05/07 - Restructured RX52 to process auto RTS/Delete
RX52 ;rxs in file 52 ^tmp("psorxdc",$j,rord,0)=52^rord^msg^rea^act^sta^dnm^apsprts
+1 ;IHS/MSC/PLS - 09/27/10 - Removed chronic med flag
IF $PIECE(^TMP("PSORXDC",$JOB,RORD,0),U,9)
DO KILLOCM^PSORN52(+RORD)
GOTO RX52E
+2 IF $PIECE(^TMP("PSORXDC",$JOB,RORD,0),U,8)
Begin DoDot:1
+3 DO EN^APSPFNC3(RORD)
+4 WRITE !," -Rx "_$PIECE(^PSRX(RORD,0),"^")_" has been auto RTS/Deleted...",!
End DoDot:1
+5 IF '$TEST
Begin DoDot:1
+6 SET PSCAN($PIECE(^PSRX(RORD,0),"^"))=RORD_"^"_$PIECE(^TMP("PSORXDC",$JOB,RORD,0),"^",4)
+7 SET MSG=$PIECE(^TMP("PSORXDC",$JOB,RORD,0),"^",3)
SET REA=$PIECE(^(0),"^",4)
SET ACT=$PIECE(^(0),"^",5)
+8 NEW PSONOOR
SET PSONOOR="D"
SET DUP=1
SET DA=RORD
DO CAN^PSOCAN
KILL PSONOOR
+9 WRITE !," -Rx "_$PIECE(^PSRX(RORD,0),"^")_" has been discontinued...",!
End DoDot:1
RX52E KILL PSOSD($PIECE(^TMP("PSORXDC",$JOB,RORD,0),"^",6),$PIECE(^TMP("PSORXDC",$JOB,RORD,0),"^",7))
+1 DO PSOUL^PSSLOCK(RORD)
KILL ^TMP("PSORXDC",$JOB,RORD,0)
+2 QUIT
+3 ;
EDIT ;
+1 SET PSORX("EDIT")=1
+2 DO ^PSONEW3
+3 SET PSONEW("DFLG")=$SELECT($GET(PSORX("DFLG")):1,1:0)
+4 QUIT
+5 ;
EOJ ;
+1 KILL PSONEW2,PSORX("EDIT"),PSORX("DFLG"),PSOEDIT,PSOSCA
+2 QUIT
+3 ;
EN1(PSONEW2) ; Entry point to just display and ask if okay
+1 SET PSONEW("DFLG")=0
+2 ; IHS/CIA/PLS - 01/06/04 - Set NDC, AWP, and COST array variables
+3 IF $GET(PSONEW2("NDC"))]""
SET PSONEW("NDC")=PSONEW2("NDC")
+4 IF $GET(PSONEW2("AWP"))]""
SET PSONEW("AWP")=PSONEW2("AWP")
+5 IF $GET(PSONEW2("COST"))]""
SET PSONEW("COST")=PSONEW2("COST")
+6 IF $GET(^PSRX(PSONEW2("IRXN"),0))']""
SET PSONEW("DFLG")=1
GOTO EN1X
+7 SET PSOX=^PSRX(PSONEW2("IRXN"),0)
SET PSONEW("TRADE NAME")=$GET(^("TN"))
SET PSONEW("FILL DATE")=$PIECE($GET(^(2)),"^",2)
+8 SET PSONEW("RX #")=$PIECE(PSOX,"^")
SET PSORX("NAME")=$PIECE(^DPT($PIECE(PSOX,"^",2),0),"^")
+9 SET PSONEW("QTY")=$PIECE(PSOX,"^",7)
SET PSODRUG("NAME")=$PIECE(^PSDRUG($PIECE(PSOX,"^",6),0),"^")
SET PSONEW("# OF REFILLS")=$PIECE(PSOX,"^",9)
+10 SET PSORX("CLERK CODE")=$PIECE(^VA(200,$PIECE(PSOX,"^",16),0),"^")
+11 IF $GET(PSONEW("PROVIDER NAME"))=""
SET PSONEW("PROVIDER NAME")=$PIECE(^VA(200,$PIECE(PSOX,"^",4),0),"^")
+12 SET PSONEW("SIG")=$PIECE($GET(^PSRX(PSONEW2("IRXN"),"SIG")),"^")
+13 DO DISPLAY
+14 DO ASK
+15 IF PSONEW("DFLG")=1
SET PSONEW2("DFLG")=1
EN1X ;
+1 QUIT
+2 ;
EXPR ;Display Expired error message ;PSO*237
+1 SET PSONEW("DFLG")=1
+2 WRITE $CHAR(7)
+3 SET VALMSG="Order is older than 365 days and can't be finished"
+4 SET XQORM("B")="DC"
+5 QUIT
