PSORXPR ;BHAM ISC/SAB - view individual prescription ;29-May-2012 15:13;PLS
;;7.0;OUTPATIENT PHARMACY;**131,1008,156,148,1015**;DEC 1997;Build 62
;Reference to ^PS(55 supported by DBIA 2228
;Reference ^PSDRUG( supported by DBIA 221
;Reference to ^SC supported by DBIA 10040
;Reference to ^PSXVIEW supported by DBIA 2204
; Modified - IHS/CIA/PLS - 01/08/04 - Lines GET+1,EN+1,PR+8
; IHS/MSC/PLS - 03/13/08 - Added line PR+20
; 01/23/09 - Added line PR+21
GET S RX0=^PSRX(DA,0),J=DA,$P(RX0,"^",15)=+$G(^("STA")),RX2=$G(^(2)),R3=$G(^(3)),RTN=$G(^("TN")) S (DFN,P0)=+$P(RX0,"^",2) S:$D(^DPT(P0,0)) P0=^(0) S FFX=0
; IHS/CIA/PLS - 01/08/04 - Setup IHS variables
N R9999999,P9999999
S R9999999=$G(^PSRX(DA,9999999))
I $G(PSOFROM)="RETURN" S APSPX9=$P(RX0,"^")
S APSPRXX=$P(RX0,U,6),APSP=DA
D:APSPMAN=1 EP1^APSPMAN1
S:APSPMAN=2 APSPMM="",APSPD=$P($G(RX2),"^",11),APSPL=""
I APSPMAN=""!(APSPMAN=3) S (APSPMM,APSPD,APSPL)=""
S PSDIV=$S($D(^PS(59,+$P(RX2,"^",9),0)):$P(^(0),"^")_" ("_$P(^(0),"^",6)_")",1:"UNKNOWN"),PSDIV=$E(PSDIV,1,28),PSEXDT=$P(RX2,"^",6),PSEXDT=$S(PSEXDT]"":$E(PSEXDT,4,5)_"/"_$E(PSEXDT,6,7)_"/"_$E(PSEXDT,2,3),1:"UNKNOWN")
PR D STAT^PSOFUNC I 'ST0,$D(^PS(52.4,"AREF",DFN,DA)) S ST="UNPRINTED"
;S:$G(PSLSTVER)&($P($G(^PSRX(+$G(PSONV),"STA")),"^")=4) ST="PENDING DUE TO DRUG INTERACTION"
D PID^VADPT W @IOF,"RX: ",$P(RX0,"^"),?20,"PATIENT: "_$P(P0,"^")_" (",VA("PID")_") ",!,"STATUS: "_ST_" "_$S($P($G(^PSRX(DA,"IB")),"^")]"":"CO-PAY STATUS",1:"") I ($D(PS)#2),PS="DISCONTINUE",ST["DISCONTINUE" S PS="REINSTATE"
;W @IOF,!,"RX: ",$P(RX0,"^"),?20,"PATIENT: ",$P(P0,"^")," (",$P(P0,"^",9),") ",!,"STATUS: ",ST_" "_$S($P($G(^PSRX(DA,"IB")),"^")]"":"CO-PAY STATUS",1:"") I ($D(PS)#2),PS="DISCONTINUE",ST["DISCONTINUE" S PS="REINSTATE"
I $G(PKI1)!($G(PKI)) N PKIT D W !,PKIT
.I '$D(IORVON) S X="IORVOFF;IORVON" D ENDR^%ZISS S PKIT=IORVON_PKIE_IORVOFF K IORVOFF,IORVON,X Q
.S PKIT=IORVON_PKIE_IORVOFF
S MED=+$P(RX0,"^",6),M1="" S:$D(^PSDRUG(MED,0)) M1=^(0) W !,$S($P(M1,"^",3)["S":" ITEM: ",1:" DRUG: "),$S(RTN'="":RTN,1:$P(M1,"^"))_$S('$D(^("I")):"",^("I")']"":"",1:" - (inactivated)")
; IHS/CIA/PLS - 01/08/04 - Output Manufacturer info
I APSPMAN=1!(APSPMAN=2) W !,"Manufacturer: "_APSPMM,?40,"Mfg Expiration Date: "_$E(APSPD,4,5)_"/"_$E(APSPD,2,3)
W !?6," NDC: ",$P(RX2,U,7)
W ?$X+2,"("_$P(R9999999,U,6)_")"
W ?$X+2,"("_$P(RX0,U,17)_")"
W:$P(R9999999,U,14)]"" ?$X+2,"TRIPLICATE# "_$P(R9999999,U,14)
W !?6," QTY: ",$P(RX0,"^",7)," ",$S($P(RX0,"^",8)?1N.N:$P(RX0,"^",8),1:"??")," DAY SUPPLY"
; IHS/CIA/PLS - 01/08/04 - Output NDC, AWP, Release Date and Triplicate #
W !?6," NDC: ",$P(RX2,U,7)
W ?$X+2,"("_$P(R9999999,U,6)_")"
W ?$X+2,"("_$P(RX0,U,17)_")"
W:$P(R9999999,U,14)]"" ?$X+2,"TRIPLICATE# "_$P(R9999999,U,14)
W !,"SUBSTITUTION : "_$$GET1^DIQ(52,DA,9999999.25) ;IHS/MSC/PLS - 03/13/08
W !,"CASH DUE: "_$$GET1^DIQ(52,DA,9999999.26) ; IHS/MSC/PLS - 01/23/09 - Added Cash Due output
; IHS/CIA/PLS - 01/08/04 - End IHS output
K FSIG,BSIG I $P($G(^PSRX(DA,"SIG")),"^",2) D FSIG^PSOUTLA("R",DA,66) F PSREV=1:1 Q:'$D(FSIG(PSREV)) S BSIG(PSREV)=FSIG(PSREV)
K FSIG,PSREV I '$P($G(^PSRX(DA,"SIG")),"^",2) D EN3^PSOUTLA1(DA,66)
W !?7,"SIG: ",$G(BSIG(1))
I $O(BSIG(1)) F PSREV=1:0 S PSREV=$O(BSIG(PSREV)) Q:'PSREV W !?12,$G(BSIG(PSREV))
K BSIG,PSREV
S II=J D LAST^PSORFL W !?4,"LATEST: ",RFLL,?37,"# OF REFILLS: ",$P(RX0,"^",9) S PL=0 D:$O(^PSRX(DA,1,0)) W " REMAINING: ",$P(RX0,"^",9)-PL K IFN
.S IFN=0 F S IFN=$O(^PSRX(DA,1,IFN)) Q:'IFN S PL=PL+1
DTT S DTT=$P(RX0,"^",13) D DAT W !?4,"ISSUED: ",DAT
K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=+$P(R3,"^",3) D ^DIC
S PHYS=$S(+Y:$P(Y,"^",2),1:"UNKNOWN") W ?41,"PROVIDER: "_PHYS S DTT=$P(RX2,"^")\1
I $P(R3,"^",3),+Y W !?41,"COSIGNER: "_$P(Y,"^",2)
D DAT W !?4,"LOGGED: ",DAT,?43,"CLINIC: ",$S($D(^SC(+$P(RX0,"^",5),0)):$P(^(0),"^"),1:"NOT ON FILE")
W !?3,"EXPIRES: ",PSEXDT,?41,"DIVISION: ",PSDIV,!?7,"CAP: ",$P("NON-^","^",$S($D(^PS(55,DFN,0)):+$P(^(0),"^",2),1:0)),"SAFETY",?42,"ROUTING: " S X=$F("MWI",$P(RX0,"^",11))-1 W:X $P("MAIL^WINDOW^INPATIENT","^",X)
K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=+$P(RX0,"^",16) D ^DIC
W !?2,"ENTRY BY: ",$S(+Y:$P(Y,"^",2),1:$P(RX0,"^",16))
K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=+$P(RX2,"^",10) D ^DIC
W:+Y ?38,"VERIFIED BY: ",$S(+Y:$P(Y,"^",2),1:$P(RX2,"^",10))
G:$D(PSOZVER) REM K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=+$P(RX2,"^",3) D ^DIC
W !!,"FILLED: "_RFL,?20,"PHARMACIST: "_$S(+Y:$P(Y,"^",2),1:""),?52,"LOT #: "_$P(RX2,"^",4)
W !," DISPENSED: "_$S($P(RX2,"^",5):$E($P(RX2,"^",5),4,5)_"/"_$E($P(RX2,"^",5),6,7)_"/"_$E($P(RX2,"^",5),2,3),1:"")
W ?$X+10,$S($P(RX2,"^",15):" RETURNED TO STOCK: "_$E($P(RX2,"^",15),4,5)_"/"_$E($P(RX2,"^",15),6,7)_"/"_$E($P(RX2,"^",15),2,3),1:" RELEASED: "_$S($P(RX2,"^",13):$E($P(RX2,"^",13),4,5)_"/"_$E($P(RX2,"^",13),6,7)_"/"_$E($P(RX2,"^",13),2,3),1:""))
REM W:$P($G(^PSRX(DA,3)),"^",7)]"" !?3,"REMARKS: ",$P($G(^PSRX(DA,3)),"^",7) W:$P($G(^PSRX(DA,"D")),"^")]"" !,"DELETION COMMENT: "_$P(^("D"),"^")
D:$G(^PSRX(DA,"H"))]""&($G(ST)="HOLD") HLD^PSORXPR1
W ! D:PL RF^PSORXPR1 G Q:$D(DIRUT) D PAR^PSORXPR1 G Q:$D(DIRUT)
ACT I $O(^PSRX(DA,"A",0)) D CON:$Y>20 G Q:$D(DIRUT) D H1 F N=0:0 S N=$O(^PSRX(DA,"A",N)) Q:'N S P1=^(N,0),DTT=P1\1 D A1 Q:$D(DIRUT)
G Q:$D(DIRUT) I $O(^PSRX(DA,"L",0)) D:$Y>20 CON Q:$D(DIRUT) D L1 F L1=0:0 S L1=$O(^PSRX(DA,"L",L1)) Q:'L1 S LBL=^PSRX(DA,"L",L1,0),DTT=$P(^(0),"^") D DAT,LG Q:$D(DIRUT)
N X S X="PSXVIEW" X ^%ZOSF("TEST") K X I $T D ^PSXVIEW
G Q
LG I $Y>20 D CON Q:$D(DIRUT) D L1
W !,L1,?3,DAT,?14,$S($P(LBL,"^",2):"REFILL "_$P(^PSRX(DA,"L",L1,0),"^",2),1:"ORIGINAL")
K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=$P(^PSRX(DA,"L",L1,0),"^",4) D ^DIC
W ?40,$P(Y,"^",2),!,"COMMENTS: "_$P(^PSRX(DA,"L",L1,0),"^",3) K DIC,X,Y
Q
A1 D CON:$Y>20 Q:$D(DIRUT) D H1:FFX,DAT W !,N,?3,DAT,?14
S X=$P(P1,"^",2),X=$F("HUCELPRWSIVDABXGKNM",X)-1
W:X $P("HOLD^UNHOLD^DISCONTINUED ^EDIT^RENEWED^PARTIAL^REINSTATE^REPRINT^SUSPENSE^RETURNED^INTERVENTION^DELETED^DRUG INTERACTION^PROCESSED^X-INTERFACE^PATIENT INST.^PKI/DEA^DISPENSE COMPLETED^ECME^","^",X)
W ?25 S X=+$P(P1,"^",4) W $S(X>0&(X<6):"REFILL "_X,X=6:"PARTIAL",X>6:"REFILL "_(X-1),1:"ORIGINAL")
K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=+$P(P1,"^",3) D ^DIC
W ?40,$S(+Y:$P(Y,"^",2),1:$P(P1,"^",3)) K DIC,X,Y
W:$P(P1,"^",5)]"" !,"COMMENTS: ",$P(P1,"^",5) Q
Q K ST0,RFL,RFLL,RFL1,ST,II,J,N,PHYS,L1,DIRUT,PSDIV,PSEXDT,MED,M1,FFX,DTT,DAT,RX0,RX2,R3,RTN,SIG,STA,P1,PL,P0,Z0,Z1,EXDT,IFN,DIR,DUOUT,DTOUT
K LBL,I,RFDATE,%H,%I K:$G(PS)="VIEW" DFN Q
H1 I FFX W @IOF
W !!,"ACTIVITY LOG:",!,"#",?3,"DATE",?14,"REASON",?25,"RX REF",?40,"INITIATOR OF ACTIVITY",! F I=1:1:79 W "="
S FFX=0 W ! Q
L1 I FFX W @IOF
W !!,"LABEL LOG:",!,"#",?3,"DATE",?14,"RX REF",?40,"PRINTED BY",! F I=1:1:79 W "="
S FFX=0 W ! Q
CON Q:$D(PSOAC) K DTOUT,DIRUT,DUOUT,DIR S DIR(0)="E" D ^DIR S FFX=1 Q
Q
DAT S DAT="",DTT=DTT\1 Q:DTT'?7N S DAT=$E(DTT,4,5)_"/"_$E(DTT,6,7)_"/"_$E(DTT,2,3)
Q
EN ; Entry Point for PSORXED
S APSPLTYP="" ; IHS/CIA/PLS - 01/08/04 - IHS Setup
D PSORXPR K PHYS,RFDATE,RFL,RFL1,ST,ST0,RFLL
Q
PSORXPR ;BHAM ISC/SAB - view individual prescription ;29-May-2012 15:13;PLS
+1 ;;7.0;OUTPATIENT PHARMACY;**131,1008,156,148,1015**;DEC 1997;Build 62
+2 ;Reference to ^PS(55 supported by DBIA 2228
+3 ;Reference ^PSDRUG( supported by DBIA 221
+4 ;Reference to ^SC supported by DBIA 10040
+5 ;Reference to ^PSXVIEW supported by DBIA 2204
+6 ; Modified - IHS/CIA/PLS - 01/08/04 - Lines GET+1,EN+1,PR+8
+7 ; IHS/MSC/PLS - 03/13/08 - Added line PR+20
+8 ; 01/23/09 - Added line PR+21
GET SET RX0=^PSRX(DA,0)
SET J=DA
SET $PIECE(RX0,"^",15)=+$GET(^("STA"))
SET RX2=$GET(^(2))
SET R3=$GET(^(3))
SET RTN=$GET(^("TN"))
SET (DFN,P0)=+$PIECE(RX0,"^",2)
IF $DATA(^DPT(P0,0))
SET P0=^(0)
SET FFX=0
+1 ; IHS/CIA/PLS - 01/08/04 - Setup IHS variables
+2 NEW R9999999,P9999999
+3 SET R9999999=$GET(^PSRX(DA,9999999))
+4 IF $GET(PSOFROM)="RETURN"
SET APSPX9=$PIECE(RX0,"^")
+5 SET APSPRXX=$PIECE(RX0,U,6)
SET APSP=DA
+6 IF APSPMAN=1
DO EP1^APSPMAN1
+7 IF APSPMAN=2
SET APSPMM=""
SET APSPD=$PIECE($GET(RX2),"^",11)
SET APSPL=""
+8 IF APSPMAN=""!(APSPMAN=3)
SET (APSPMM,APSPD,APSPL)=""
+9 SET PSDIV=$SELECT($DATA(^PS(59,+$PIECE(RX2,"^",9),0)):$PIECE(^(0),"^")_" ("_$PIECE(^(0),"^",6)_")",1:"UNKNOWN")
SET PSDIV=$EXTRACT(PSDIV,1,28)
SET PSEXDT=$PIECE(RX2,"^",6)
SET PSEXDT=$SELECT(PSEXDT]"":$EXTRACT(PSEXDT,4,5)_"/"_$EXTRACT(PSEXDT,6,7)_"/"_$EXTRACT(PSEXDT,2,3),1:"UNKNOWN")
PR DO STAT^PSOFUNC
IF 'ST0
IF $DATA(^PS(52.4,"AREF",DFN,DA))
SET ST="UNPRINTED"
+1 ;S:$G(PSLSTVER)&($P($G(^PSRX(+$G(PSONV),"STA")),"^")=4) ST="PENDING DUE TO DRUG INTERACTION"
+2 DO PID^VADPT
WRITE @IOF,"RX: ",$PIECE(RX0,"^"),?20,"PATIENT: "_$PIECE(P0,"^")_" (",VA("PID")_") ",!,"STATUS: "_ST_" "_$SELECT($PIECE($GET(^PSRX(DA,"IB")),"^")]"":"CO-PAY STATUS",1:"")
IF ($DATA(PS)#2)
IF PS="DISCONTINUE"
IF ST["DISCONTINUE"
SET PS="REINSTATE"
+3 ;W @IOF,!,"RX: ",$P(RX0,"^"),?20,"PATIENT: ",$P(P0,"^")," (",$P(P0,"^",9),") ",!,"STATUS: ",ST_" "_$S($P($G(^PSRX(DA,"IB")),"^")]"":"CO-PAY STATUS",1:"") I ($D(PS)#2),PS="DISCONTINUE",ST["DISCONTINUE" S PS="REINSTATE"
+4 IF $GET(PKI1)!($GET(PKI))
NEW PKIT
Begin DoDot:1
+5 IF '$DATA(IORVON)
SET X="IORVOFF;IORVON"
DO ENDR^%ZISS
SET PKIT=IORVON_PKIE_IORVOFF
KILL IORVOFF,IORVON,X
QUIT
+6 SET PKIT=IORVON_PKIE_IORVOFF
End DoDot:1
WRITE !,PKIT
+7 SET MED=+$PIECE(RX0,"^",6)
SET M1=""
IF $DATA(^PSDRUG(MED,0))
SET M1=^(0)
WRITE !,$SELECT($PIECE(M1,"^",3)["S":" ITEM: ",1:" DRUG: "),$SELECT(RTN'="":RTN,1:$PIECE(M1,"^"))_$SELECT('$DATA(^("I")):"",^("I")']"":"",1:" - (inactivated)")
+8 ; IHS/CIA/PLS - 01/08/04 - Output Manufacturer info
+9 IF APSPMAN=1!(APSPMAN=2)
WRITE !,"Manufacturer: "_APSPMM,?40,"Mfg Expiration Date: "_$EXTRACT(APSPD,4,5)_"/"_$EXTRACT(APSPD,2,3)
+10 WRITE !?6," NDC: ",$PIECE(RX2,U,7)
+11 WRITE ?$X+2,"("_$PIECE(R9999999,U,6)_")"
+12 WRITE ?$X+2,"("_$PIECE(RX0,U,17)_")"
+13 IF $PIECE(R9999999,U,14)]""
WRITE ?$X+2,"TRIPLICATE# "_$PIECE(R9999999,U,14)
+14 WRITE !?6," QTY: ",$PIECE(RX0,"^",7)," ",$SELECT($PIECE(RX0,"^",8)?1N.N:$PIECE(RX0,"^",8),1:"??")," DAY SUPPLY"
+15 ; IHS/CIA/PLS - 01/08/04 - Output NDC, AWP, Release Date and Triplicate #
+16 WRITE !?6," NDC: ",$PIECE(RX2,U,7)
+17 WRITE ?$X+2,"("_$PIECE(R9999999,U,6)_")"
+18 WRITE ?$X+2,"("_$PIECE(RX0,U,17)_")"
+19 IF $PIECE(R9999999,U,14)]""
WRITE ?$X+2,"TRIPLICATE# "_$PIECE(R9999999,U,14)
+20 ;IHS/MSC/PLS - 03/13/08
WRITE !,"SUBSTITUTION : "_$$GET1^DIQ(52,DA,9999999.25)
+21 ; IHS/MSC/PLS - 01/23/09 - Added Cash Due output
WRITE !,"CASH DUE: "_$$GET1^DIQ(52,DA,9999999.26)
+22 ; IHS/CIA/PLS - 01/08/04 - End IHS output
+23 KILL FSIG,BSIG
IF $PIECE($GET(^PSRX(DA,"SIG")),"^",2)
DO FSIG^PSOUTLA("R",DA,66)
FOR PSREV=1:1
IF '$DATA(FSIG(PSREV))
QUIT
SET BSIG(PSREV)=FSIG(PSREV)
+24 KILL FSIG,PSREV
IF '$PIECE($GET(^PSRX(DA,"SIG")),"^",2)
DO EN3^PSOUTLA1(DA,66)
+25 WRITE !?7,"SIG: ",$GET(BSIG(1))
+26 IF $ORDER(BSIG(1))
FOR PSREV=1:0
SET PSREV=$ORDER(BSIG(PSREV))
IF 'PSREV
QUIT
WRITE !?12,$GET(BSIG(PSREV))
+27 KILL BSIG,PSREV
+28 SET II=J
DO LAST^PSORFL
WRITE !?4,"LATEST: ",RFLL,?37,"# OF REFILLS: ",$PIECE(RX0,"^",9)
SET PL=0
IF $ORDER(^PSRX(DA,1,0))
Begin DoDot:1
+29 SET IFN=0
FOR
SET IFN=$ORDER(^PSRX(DA,1,IFN))
IF 'IFN
QUIT
SET PL=PL+1
End DoDot:1
WRITE " REMAINING: ",$PIECE(RX0,"^",9)-PL
KILL IFN
DTT SET DTT=$PIECE(RX0,"^",13)
DO DAT
WRITE !?4,"ISSUED: ",DAT
+1 KILL DIC,X,Y
SET DIC="^VA(200,"
SET DIC(0)="N,Z"
SET X=+$PIECE(R3,"^",3)
DO ^DIC
+2 SET PHYS=$SELECT(+Y:$PIECE(Y,"^",2),1:"UNKNOWN")
WRITE ?41,"PROVIDER: "_PHYS
SET DTT=$PIECE(RX2,"^")\1
+3 IF $PIECE(R3,"^",3)
IF +Y
WRITE !?41,"COSIGNER: "_$PIECE(Y,"^",2)
+4 DO DAT
WRITE !?4,"LOGGED: ",DAT,?43,"CLINIC: ",$SELECT($DATA(^SC(+$PIECE(RX0,"^",5),0)):$PIECE(^(0),"^"),1:"NOT ON FILE")
+5 WRITE !?3,"EXPIRES: ",PSEXDT,?41,"DIVISION: ",PSDIV,!?7,"CAP: ",$PIECE("NON-^","^",$SELECT($DATA(^PS(55,DFN,0)):+$PIECE(^(0),"^",2),1:0)),"SAFETY",?42,"ROUTING: "
SET X=$FIND("MWI",$PIECE(RX0,"^",11))-1
IF X
WRITE $PIECE("MAIL^WINDOW^INPATIENT","^",X)
+6 KILL DIC,X,Y
SET DIC="^VA(200,"
SET DIC(0)="N,Z"
SET X=+$PIECE(RX0,"^",16)
DO ^DIC
+7 WRITE !?2,"ENTRY BY: ",$SELECT(+Y:$PIECE(Y,"^",2),1:$PIECE(RX0,"^",16))
+8 KILL DIC,X,Y
SET DIC="^VA(200,"
SET DIC(0)="N,Z"
SET X=+$PIECE(RX2,"^",10)
DO ^DIC
+9 IF +Y
WRITE ?38,"VERIFIED BY: ",$SELECT(+Y:$PIECE(Y,"^",2),1:$PIECE(RX2,"^",10))
+10 IF $DATA(PSOZVER)
GOTO REM
KILL DIC,X,Y
SET DIC="^VA(200,"
SET DIC(0)="N,Z"
SET X=+$PIECE(RX2,"^",3)
DO ^DIC
+11 WRITE !!,"FILLED: "_RFL,?20,"PHARMACIST: "_$SELECT(+Y:$PIECE(Y,"^",2),1:""),?52,"LOT #: "_$PIECE(RX2,"^",4)
+12 WRITE !," DISPENSED: "_$SELECT($PIECE(RX2,"^",5):$EXTRACT($PIECE(RX2,"^",5),4,5)_"/"_$EXTRACT($PIECE(RX2,"^",5),6,7)_"/"_$EXTRACT($PIECE(RX2,"^",5),2,3),1:"")
+13 WRITE ?$X+10,$SELECT(...
WRITE $PIECE(RX2,"^",15):" RETURNED TO STOCK: "_$EXTRACT($PIECE(RX2,"^",15),4,5)_"/"_...
... $EXTRACT($PIECE(RX2,"^",15),6,7)_"/"_$EXTRACT($PIECE(RX2,"^",15),2,3),1:" RELEASED: "_$SELECT($PIECE(RX2,"^",13):$EXTRACT($PIECE(RX2,"^",13),4,5)_"/"_$EXTRACT($PIECE(RX2,"^",13),6,7)_"/"_$EXTRACT($PIECE(RX2,"^",13),2,3),1:""))
REM IF $PIECE($GET(^PSRX(DA,3)),"^",7)]""
WRITE !?3,"REMARKS: ",$PIECE($GET(^PSRX(DA,3)),"^",7)
IF $PIECE($GET(^PSRX(DA,"D")),"^")]""
WRITE !,"DELETION COMMENT: "_$PIECE(^("D"),"^")
+1 IF $GET(^PSRX(DA,"H"))]""&($GET(ST)="HOLD")
DO HLD^PSORXPR1
+2 WRITE !
IF PL
DO RF^PSORXPR1
IF $DATA(DIRUT)
GOTO Q
DO PAR^PSORXPR1
IF $DATA(DIRUT)
GOTO Q
ACT IF $ORDER(^PSRX(DA,"A",0))
IF $Y>20
DO CON
IF $DATA(DIRUT)
GOTO Q
DO H1
FOR N=0:0
SET N=$ORDER(^PSRX(DA,"A",N))
IF 'N
QUIT
SET P1=^(N,0)
SET DTT=P1\1
DO A1
IF $DATA(DIRUT)
QUIT
+1 IF $DATA(DIRUT)
GOTO Q
IF $ORDER(^PSRX(DA,"L",0))
IF $Y>20
DO CON
IF $DATA(DIRUT)
QUIT
DO L1
FOR L1=0:0
SET L1=$ORDER(^PSRX(DA,"L",L1))
IF 'L1
QUIT
SET LBL=^PSRX(DA,"L",L1,0)
SET DTT=$PIECE(^(0),"^")
DO DAT
DO LG
IF $DATA(DIRUT)
QUIT
+2 NEW X
SET X="PSXVIEW"
XECUTE ^%ZOSF("TEST")
KILL X
IF $TEST
DO ^PSXVIEW
+3 GOTO Q
LG IF $Y>20
DO CON
IF $DATA(DIRUT)
QUIT
DO L1
+1 WRITE !,L1,?3,DAT,?14,$SELECT($PIECE(LBL,"^",2):"REFILL "_$PIECE(^PSRX(DA,"L",L1,0),"^",2),1:"ORIGINAL")
+2 KILL DIC,X,Y
SET DIC="^VA(200,"
SET DIC(0)="N,Z"
SET X=$PIECE(^PSRX(DA,"L",L1,0),"^",4)
DO ^DIC
+3 WRITE ?40,$PIECE(Y,"^",2),!,"COMMENTS: "_$PIECE(^PSRX(DA,"L",L1,0),"^",3)
KILL DIC,X,Y
+4 QUIT
A1 IF $Y>20
DO CON
IF $DATA(DIRUT)
QUIT
IF FFX
DO H1
DO DAT
WRITE !,N,?3,DAT,?14
+1 SET X=$PIECE(P1,"^",2)
SET X=$FIND("HUCELPRWSIVDABXGKNM",X)-1
+2 IF X
WRITE $PIECE("HOLD^UNHOLD^DISCONTINUED ^EDIT^RENEWED^PARTIAL^REINSTATE^REPRINT^SUSPENSE^RETURNED^INTERVENTION^DELETED^DRUG INTERACTION^PROCESSED^X-INTERFACE^PATIENT INST.^PKI/DEA^DISPENSE COMPLETED^ECME^","^",X)
+3 WRITE ?25
SET X=+$PIECE(P1,"^",4)
WRITE $SELECT(X>0&(X<6):"REFILL "_X,X=6:"PARTIAL",X>6:"REFILL "_(X-1),1:"ORIGINAL")
+4 KILL DIC,X,Y
SET DIC="^VA(200,"
SET DIC(0)="N,Z"
SET X=+$PIECE(P1,"^",3)
DO ^DIC
+5 WRITE ?40,$SELECT(+Y:$PIECE(Y,"^",2),1:$PIECE(P1,"^",3))
KILL DIC,X,Y
+6 IF $PIECE(P1,"^",5)]""
WRITE !,"COMMENTS: ",$PIECE(P1,"^",5)
QUIT
Q KILL ST0,RFL,RFLL,RFL1,ST,II,J,N,PHYS,L1,DIRUT,PSDIV,PSEXDT,MED,M1,FFX,DTT,DAT,RX0,RX2,R3,RTN,SIG,STA,P1,PL,P0,Z0,Z1,EXDT,IFN,DIR,DUOUT,DTOUT
+1 KILL LBL,I,RFDATE,%H,%I
IF $GET(PS)="VIEW"
KILL DFN
QUIT
H1 IF FFX
WRITE @IOF
+1 WRITE !!,"ACTIVITY LOG:",!,"#",?3,"DATE",?14,"REASON",?25,"RX REF",?40,"INITIATOR OF ACTIVITY",!
FOR I=1:1:79
WRITE "="
+2 SET FFX=0
WRITE !
QUIT
L1 IF FFX
WRITE @IOF
+1 WRITE !!,"LABEL LOG:",!,"#",?3,"DATE",?14,"RX REF",?40,"PRINTED BY",!
FOR I=1:1:79
WRITE "="
+2 SET FFX=0
WRITE !
QUIT
CON IF $DATA(PSOAC)
QUIT
KILL DTOUT,DIRUT,DUOUT,DIR
SET DIR(0)="E"
DO ^DIR
SET FFX=1
QUIT
+1 QUIT
DAT SET DAT=""
SET DTT=DTT\1
IF DTT'?7N
QUIT
SET DAT=$EXTRACT(DTT,4,5)_"/"_$EXTRACT(DTT,6,7)_"/"_$EXTRACT(DTT,2,3)
+1 QUIT
EN ; Entry Point for PSORXED
+1 ; IHS/CIA/PLS - 01/08/04 - IHS Setup
SET APSPLTYP=""
+2 DO PSORXPR
KILL PHYS,RFDATE,RFL,RFL1,ST,ST0,RFLL
+3 QUIT
