PSORXEDT ;BIR/SAB-edit rx routine ;29-May-2012 15:12;PLS
;;7.0;OUTPATIENT PHARMACY;**21,23,44,71,146,185,148,253,1015**;DEC 1997;Build 62
;Ref. ^PS(55 supp. IA 2228
; Modified - IHS/CIA/PLS - 12/10/03 - Line LIST+4
D:'$D(PSOPAR) ^PSOLSET I '$D(PSOPAR) G EOJ Q
K PSODRUG,PSOLIST,DIR,DIRUT,DUOUT,X,Y,PSOFROM,^TMP("PSOBEDT",$J),NOPP,CLOZPST
W !! S DIR(0)="FAO^1:245",DIR("A")="Edit Rx(s) => ",DIR("?",1)="Enter Rx Number or A List of numbers Separated",DIR("?")="by Commas, e.g. 1234A,345,937002Q."
D ^DIR K DIR G:$D(DIRUT) EOJ
S END=$L(X,","),BAD=0
F I=1:1:END S RXM=$P(X,",",I) I +RXM F J=I+1:1:END S DUP=$P(X,",",J) I DUP=RXM S $P(X,",",J)="" W !?5,$C(7),"Duplicate Rx # "_RXM_" was found in your list, ignoring it!",! S BAD=1
S PSORLST=$P(X,",") F I=2:1:END S RXM=$P(X,",",I) S:RXM'?1.N.A BAD=1 I RXM?1.N.A S PSORLST=PSORLST_","_RXM
F I=1:1:$L(PSORLST) S RXM=$P(PSORLST,",",I) I +RXM F J=I+1:1:END S DUP=$P(PSORLST,",",J) I DUP=RXM S $P(PSORLST,",",J)=""
BAD I PSORLST D I 'Y K Y G PSORXEDT
.W !?15,"=> "_PSORLST
.K DIR,DIRUT S DIR(0)="Y",DIR("A")="Is this OKAY ",DIR("B")="Yes"
.D ^DIR K DIR
.I 'Y!$D(DIRUT) K X,PSORLST,BAD
K BAD I 'PSORLST K PSORLST G PSORXEDT
F I=1:1:$L(PSORLST,",") S RXM=$P(PSORLST,",",I) S GOOD=$D(^PSRX("B",RXM)) D
.I 'GOOD W !!?5,"Couldn't Find RX # "_RXM H 3 Q
.S RXN=$O(^PSRX("B",RXM,0)) D I $P(^PSRX(RXN,"STA"),"^")=13 W !!?5,"Rx # "_RXM_" is marked for Deletion." H 3 Q
..I $G(RXN),$P($G(^PS(55,+$P($G(^PSRX(RXN,0)),"^",2),0)),"^",6)'=2 S PSOLOUD=1 D EN^PSOHLUP(+$P($G(^PSRX(RXN,0)),"^",2)) K PSOLOUD
.D LIST K GOOD
K GOOD,END
EPH ; - Entry for Epharmacy Rx Edit (PSOREJP1)
F PSOT1=1:1 Q:'$D(PSOLIST(PSOT1)) F PSOLST2=1:1:$L(PSOLIST(PSOT1),",") S ORN=$P(PSOLIST(PSOT1),",",PSOLST2) D:+ORN PT
;call to add bingo board data to file 52.11
K POP,PSOLIST,TM,TM1 G:'$O(PSORX("PSOL",0)) NX
D:$G(PSORX("PSOL",1))]"" ^PSORXL K PSORX G:$G(NOBG) NX
PRF G:'$P(PSOPAR,"^",8)!($G(NOPP)="H")!($G(NOPP)="S")!('$D(^TMP("PSOBEDT",$J))) BBG
I $O(^TMP("PSOBEDT",$J,0)),$P(PSOPAR,"^",8) S PSOFROM="NEW",PSOION=ION K RXRS
G:$D(PSOPROP)&($G(PSOPROP)'=ION) QUP
I '$D(PSOPROP)!($G(PSOPROP)=ION) D G:$G(POP)!($E(IOST)["C")!(PSOION=ION) BBG
.S PSOION=ION W !,"Profiles must be sent to Printer !!",! K IOP,%ZIS,IO("Q"),POP
.S %ZIS="MNQ",%ZIS("A")="Select Profile Device: " D ^%ZIS K %ZIS("A")
.Q:$G(POP)!($E(IOST)["C")!(PSOION=ION) S PSOPROP=ION
QUP S X1=DT,X2=-120 D C^%DTC S PSODTCUT=X,HOLDRPAS=$G(PSOPRPAS),PSOPRPAS=$P(PSOPAR,"^",13)
F DFN=0:0 S DFN=$O(^TMP("PSOBEDT",$J,DFN)) Q:'DFN S PPL=^TMP("PSOBEDT",$J,DFN,0) D
.S ZTRTN="DQ^PSOPRF",ZTIO=PSOPROP,ZTDESC="Outpatient Pharmacy Patient Profiles",ZTDTH=$H
.F G="PSOPAR","PSODTCUT","PSOPRPAS","DFN","PSOSITE","NEW1","NEW11","PSOBMST","PFIO","PPL" S:$D(@G) ZTSAVE(G)=""
.D ^%ZTLOAD
W:$D(ZTSK) !,"PROFILE(S) QUEUED to PRINT",!! K G,ZTSK D ^%ZISC
S PSOPRPAS=$G(HOLDRPAS) K:PSOPRPAS']"" PSOPRPAS K HOLDRPAS
BBG K DFN F PSODFN=0:0 S PSODFN=$O(^TMP("PSOBEDT",$J,PSODFN)) Q:'PSODFN I $G(^TMP("PSOBEDT",$J,PSODFN,1)),$D(DISGROUP) S TM=$P($G(^TMP("PSOBB",$J)),"^"),TM1=$P($G(^($J)),"^",2),PPL=^TMP("PSOBEDT",$J,PSODFN,0) D ^PSOBING1
NX ;
K %X,%Y,ACTREF,ACTREN,D,D0,DAT,DFN,DIC,DIQ,DQ,DRG,END,FDR,PSOBEDT,TM,TM1,PSOT1,PSOLST2,NOBG,BBFLG,BINGCRT,BINGRTE,C,CC,CMOP,COM,CT,D1,DI,DREN,BBRX,PSOFROM,POP,PSORX("QFLG"),IT,PSOERR,PSOBCK,PSOBM,PPL
K ^TMP("PSOBEDT",$J),^TMP("PSOBB",$J),ZTSK,NOPP,VALMSG,VALMBCK D EOJ
END Q
;---------------------------------------------------------
PT ;
N PSOTXEDT,PSOTPEXT S PSOTXEDT=$P($G(^PSRX(ORN,0)),"^",2) I PSOTXEDT I $D(^PS(52.91,PSOTXEDT,0)) I '$P(^PS(52.91,PSOTXEDT,0),"^",3)!($P(^(0),"^",3)>DT) D PDIR^PSOTPCAN(PSOTXEDT) I $G(PSOTPEXT) K PSOTPEXT,PSOTXEDT D EOJ Q
K PSOTXEDT,PSOTPEXT
D NOW^%DTC S TM=$E(%,1,12),TM1=$P(TM,".",2) S ^TMP("PSOBB",$J)=TM_"^"_TM1
S $P(PSOLST(ORN),"^",2)=ORN,(PSOBEDT)=1
S (DFN,PSODFN)=+$P(^PSRX(ORN,0),"^",2),PSORX("NAME")=$P(^DPT(DFN,0),"^")
D ICN^PSODPT(DFN)
S RX0=^PSRX(ORN,0),RX2=$G(^(2)),RX3=$G(^(3))
D:$G(DUZ("AG"))="V" COPAY^PSOPTPST ; Deals with copay
K ^TMP("PSOHDR",$J),^TMP("PSOPI",$J) D ^VADPT,ADD^VADPT
S ^TMP("PSOHDR",$J,1,0)=VADM(1),^TMP("PSOHDR",$J,2,0)=$P(VADM(2),"^",2)
S ^TMP("PSOHDR",$J,3,0)=$P(VADM(3),"^",2)
S ^TMP("PSOHDR",$J,4,0)=VADM(4),^TMP("PSOHDR",$J,5,0)=$P(VADM(5),"^",2)
S POERR=1 D RE^PSODEM K POERR,VALMBCK
S ^TMP("PSOHDR",$J,6,0)=$S($P(WT,"^",8):$P(WT,"^",9)_" ("_$P(WT,"^")_")",1:"_______ (______)")
S ^TMP("PSOHDR",$J,7,0)=$S($P(HT,"^",8):$P(HT,"^",9)_" ("_$P(HT,"^")_")",1:"_______ (______)") K VM,WT,HT S PSOHD=7
S ^TMP("PSOHDR",$J,9,0)="",^TMP("PSOHDR",$J,10,0)=""
S GMRA="0^0^111" D ^GMRADPT S ^TMP("PSOHDR",$J,8,0)=+$G(GMRAL)
D NOW^%DTC S TM=$E(%,1,12),TM1=$P(TM,".",2) S ^TMP("PSOBB",$J)=TM_"^"_TM1
S PSOLOUD=1 D:$P($G(^PS(55,PSODFN,0)),"^",6)'=2 EN^PSOHLUP(PSODFN) K PSOLOUD
S PSOX=$G(^PS(55,PSODFN,"PS")) I PSOX]"" S PSORX("PATIENT STATUS")=$P($G(^PS(53,PSOX,0)),"^")
D CLEAR^VALM1
S STA="ACTIVE^NON-VERIFIED^REFILL^HOLD^NON-VERIFIED^SUSPENDED^^^^^^EXPIRED^DISCONTINUED^^DISCONTINUED^DISCONTINUED^HOLD"
S $P(PSOLST(ORN),"^",3)=$P(STA,"^",$P(^PSRX(ORN,"STA"),"^")+1),PSLST=ORN,ORD=1
D ACT^PSOORNE2
EOJ ;
K INS1,HDR,IK,INDT,LOG,NODE,ORN,P1,PSI,PSL,PSOLION,PSNP,PSOACT,PSOBM,PSOCLC,PSOCNT,PSODD,PSODFN,PSOHD,PSOJ,PSOLST,PSOOI,PSOPF,PSLST
K PSOIBQS,PSORLST,PSOSD,PSOSIG,PSPRXN,PSORX0,PSORX1,PTST,REFL,RF,RFD,RIFN,RLD,RPH,RTS,RX0,RX1,RX2,RX3,RXM,RXOR,SIG,SIGOK
D KVA^VADPT K SLPPL,ST,STA,^TMP("PS",$J),PSOQFLG,PSORXED,PSOEDIT,DIR,DIRUT,DUOUT,DTOUT,PSOLOUD,GMRAL,GG,FEV,ACNT
D FULL^VALM1 K ^TMP("PSOAL",$J),^TMP("PSOAO",$J),^TMP("PSOSF",$J),^TMP("PSOPF",$J),^TMP("PSOPI",$J),^TMP("PSOPO",$J),^TMP("PSOHDR",$J),PAT
K JJ,K,MM,PSDAYS,PSOAC,PSOAL,PSOCOU,PSOCOUU,PSONEW,PSODRUG,PSONOOR,PSRX0,QTY,REA,RFCNT,RFDT,RXDA,RXFL,RXREF,SUB,X,Z,ZII
K ACOM,CRIT,DA,DDH,DGI,DGS,PSONEW3,SER,SERS,ZONE,RN,RXN,PSOX,PSOERR,ORD,PSOBCK,PSOBILL,SURX,PSORX("QFLG"),PSORX("FN"),CLOZPAT
Q
LIST ;
I $G(^PSRX(RXN,0))']"" W !,$C(7),"Rx data is not on file !",! G LISTX
I $P(^PSRX(RXN,0),"^",15)=13 S PSVD=1 W !,$C(7),"Rx # "_RXM_" has been deleted."
S RXN1=RXN,RXM1=RXM D:'$G(PSVD) LST1 W "." S RXN=RXN1,RXM=RXM1 K RXN1,RXM1
; IHS/CIA/PLS - 12/10/03 - Prevent UNDEF error from kill of RXN in LST1 subroutine
;F S RXN=$O(^PSRX("B",RXM,RXN)) Q:'RXN D
F S RXN=$O(^PSRX("B",RXM,$G(RXN))) Q:'RXN D
.I $G(^PSRX(RXN,0))']"" Q
.I $P(^PSRX(RXN,0),"^",15)=13 Q
.D LST1
K RXN1 G LISTX
Q
LST1 I $G(PSOLIST(1))']"" S PSOLIST(1)=RXN_"," G LISTX
F PSOX1=0:0 S PSOX1=$O(PSOLIST(PSOX1)) Q:'PSOX1 S PSOX2=PSOX1
I $L(PSOLIST(PSOX2))+$L(RXN)<220 S:RXN_","'[PSOLIST(PSOX2) PSOLIST(PSOX2)=PSOLIST(PSOX2)_RXN_","
E S:RXN_","'[PSOLIST(PSOX2+1) PSOLIST(PSOX2+1)=RXN_","
LISTX K PSOX1,PSOX2,RXN,PSVD
Q
PSORXEDT ;BIR/SAB-edit rx routine ;29-May-2012 15:12;PLS
+1 ;;7.0;OUTPATIENT PHARMACY;**21,23,44,71,146,185,148,253,1015**;DEC 1997;Build 62
+2 ;Ref. ^PS(55 supp. IA 2228
+3 ; Modified - IHS/CIA/PLS - 12/10/03 - Line LIST+4
+4 IF '$DATA(PSOPAR)
DO ^PSOLSET
IF '$DATA(PSOPAR)
GOTO EOJ
QUIT
+5 KILL PSODRUG,PSOLIST,DIR,DIRUT,DUOUT,X,Y,PSOFROM,^TMP("PSOBEDT",$JOB),NOPP,CLOZPST
+6 WRITE !!
SET DIR(0)="FAO^1:245"
SET DIR("A")="Edit Rx(s) => "
SET DIR("?",1)="Enter Rx Number or A List of numbers Separated"
SET DIR("?")="by Commas, e.g. 1234A,345,937002Q."
+7 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
GOTO EOJ
+8 SET END=$LENGTH(X,",")
SET BAD=0
+9 FOR I=1:1:END
SET RXM=$PIECE(X,",",I)
IF +RXM
FOR J=I+1:1:END
SET DUP=$PIECE(X,",",J)
IF DUP=RXM
SET $PIECE(X,",",J)=""
WRITE !?5,$CHAR(7),"Duplicate Rx # "_RXM_" was found in your list, ignoring it!",!
SET BAD=1
+10 SET PSORLST=$PIECE(X,",")
FOR I=2:1:END
SET RXM=$PIECE(X,",",I)
IF RXM'?1.N.A
SET BAD=1
IF RXM?1.N.A
SET PSORLST=PSORLST_","_RXM
+11 FOR I=1:1:$LENGTH(PSORLST)
SET RXM=$PIECE(PSORLST,",",I)
IF +RXM
FOR J=I+1:1:END
SET DUP=$PIECE(PSORLST,",",J)
IF DUP=RXM
SET $PIECE(PSORLST,",",J)=""
BAD IF PSORLST
Begin DoDot:1
+1 WRITE !?15,"=> "_PSORLST
+2 KILL DIR,DIRUT
SET DIR(0)="Y"
SET DIR("A")="Is this OKAY "
SET DIR("B")="Yes"
+3 DO ^DIR
KILL DIR
+4 IF 'Y!$DATA(DIRUT)
KILL X,PSORLST,BAD
End DoDot:1
IF 'Y
KILL Y
GOTO PSORXEDT
+5 KILL BAD
IF 'PSORLST
KILL PSORLST
GOTO PSORXEDT
+6 FOR I=1:1:$LENGTH(PSORLST,",")
SET RXM=$PIECE(PSORLST,",",I)
SET GOOD=$DATA(^PSRX("B",RXM))
Begin DoDot:1
+7 IF 'GOOD
WRITE !!?5,"Couldn't Find RX # "_RXM
HANG 3
QUIT
+8 SET RXN=$ORDER(^PSRX("B",RXM,0))
Begin DoDot:2
+9 IF $GET(RXN)
IF $PIECE($GET(^PS(55,+$PIECE($GET(^PSRX(RXN,0)),"^",2),0)),"^",6)'=2
SET PSOLOUD=1
DO EN^PSOHLUP(+$PIECE($GET(^PSRX(RXN,0)),"^",2))
KILL PSOLOUD
End DoDot:2
IF $PIECE(^PSRX(RXN,"STA"),"^")=13
WRITE !!?5,"Rx # "_RXM_" is marked for Deletion."
HANG 3
QUIT
+10 DO LIST
KILL GOOD
End DoDot:1
+11 KILL GOOD,END
EPH ; - Entry for Epharmacy Rx Edit (PSOREJP1)
+1 FOR PSOT1=1:1
IF '$DATA(PSOLIST(PSOT1))
QUIT
FOR PSOLST2=1:1:$LENGTH(PSOLIST(PSOT1),",")
SET ORN=$PIECE(PSOLIST(PSOT1),",",PSOLST2)
IF +ORN
DO PT
+2 ;call to add bingo board data to file 52.11
+3 KILL POP,PSOLIST,TM,TM1
IF '$ORDER(PSORX("PSOL",0))
GOTO NX
+4 IF $GET(PSORX("PSOL",1))]""
DO ^PSORXL
KILL PSORX
IF $GET(NOBG)
GOTO NX
PRF IF '$PIECE(PSOPAR,"^",8)!($GET(NOPP)="H")!($GET(NOPP)="S")!('$DATA(^TMP("PSOBEDT",$JOB)))
GOTO BBG
+1 IF $ORDER(^TMP("PSOBEDT",$JOB,0))
IF $PIECE(PSOPAR,"^",8)
SET PSOFROM="NEW"
SET PSOION=ION
KILL RXRS
+2 IF $DATA(PSOPROP)&($GET(PSOPROP)'=ION)
GOTO QUP
+3 IF '$DATA(PSOPROP)!($GET(PSOPROP)=ION)
Begin DoDot:1
+4 SET PSOION=ION
WRITE !,"Profiles must be sent to Printer !!",!
KILL IOP,%ZIS,IO("Q"),POP
+5 SET %ZIS="MNQ"
SET %ZIS("A")="Select Profile Device: "
DO ^%ZIS
KILL %ZIS("A")
+6 IF $GET(POP)!($EXTRACT(IOST)["C")!(PSOION=ION)
QUIT
SET PSOPROP=ION
End DoDot:1
IF $GET(POP)!($EXTRACT(IOST)["C")!(PSOION=ION)
GOTO BBG
QUP SET X1=DT
SET X2=-120
DO C^%DTC
SET PSODTCUT=X
SET HOLDRPAS=$GET(PSOPRPAS)
SET PSOPRPAS=$PIECE(PSOPAR,"^",13)
+1 FOR DFN=0:0
SET DFN=$ORDER(^TMP("PSOBEDT",$JOB,DFN))
IF 'DFN
QUIT
SET PPL=^TMP("PSOBEDT",$JOB,DFN,0)
Begin DoDot:1
+2 SET ZTRTN="DQ^PSOPRF"
SET ZTIO=PSOPROP
SET ZTDESC="Outpatient Pharmacy Patient Profiles"
SET ZTDTH=$HOROLOG
+3 FOR G="PSOPAR","PSODTCUT","PSOPRPAS","DFN","PSOSITE","NEW1","NEW11","PSOBMST","PFIO","PPL"
IF $DATA(@G)
SET ZTSAVE(G)=""
+4 DO ^%ZTLOAD
End DoDot:1
+5 IF $DATA(ZTSK)
WRITE !,"PROFILE(S) QUEUED to PRINT",!!
KILL G,ZTSK
DO ^%ZISC
+6 SET PSOPRPAS=$GET(HOLDRPAS)
IF PSOPRPAS']""
KILL PSOPRPAS
KILL HOLDRPAS
BBG KILL DFN
FOR PSODFN=0:0
SET PSODFN=$ORDER(^TMP("PSOBEDT",$JOB,PSODFN))
IF 'PSODFN
QUIT
IF $GET(^TMP("PSOBEDT",$JOB,PSODFN,1))
IF $DATA(DISGROUP)
SET TM=$PIECE($GET(^TMP("PSOBB",$JOB)),"^")
SET TM1=$PIECE($GET(^($JOB)),"^",2)
SET PPL=^TMP("PSOBEDT",$JOB,PSODFN,0)
DO ^PSOBING1
NX ;
+1 KILL %X,%Y,ACTREF,ACTREN,D,D0,DAT,DFN,DIC,DIQ,DQ,DRG,END,FDR,PSOBEDT,TM,TM1,PSOT1,PSOLST2,NOBG,BBFLG,BINGCRT,BINGRTE,C,CC,CMOP,COM,CT,D1,DI,DREN,BBRX,PSOFROM,POP,PSORX("QFLG"),IT,PSOERR,PSOBCK,PSOBM,PPL
+2 KILL ^TMP("PSOBEDT",$JOB),^TMP("PSOBB",$JOB),ZTSK,NOPP,VALMSG,VALMBCK
DO EOJ
END QUIT
+1 ;---------------------------------------------------------
PT ;
+1 NEW PSOTXEDT,PSOTPEXT
SET PSOTXEDT=$PIECE($GET(^PSRX(ORN,0)),"^",2)
IF PSOTXEDT
IF $DATA(^PS(52.91,PSOTXEDT,0))
IF '$PIECE(^PS(52.91,PSOTXEDT,0),"^",3)!($PIECE(^(0),"^",3)>DT)
DO PDIR^PSOTPCAN(PSOTXEDT)
IF $GET(PSOTPEXT)
KILL PSOTPEXT,PSOTXEDT
DO EOJ
QUIT
+2 KILL PSOTXEDT,PSOTPEXT
+3 DO NOW^%DTC
SET TM=$EXTRACT(%,1,12)
SET TM1=$PIECE(TM,".",2)
SET ^TMP("PSOBB",$JOB)=TM_"^"_TM1
+4 SET $PIECE(PSOLST(ORN),"^",2)=ORN
SET (PSOBEDT)=1
+5 SET (DFN,PSODFN)=+$PIECE(^PSRX(ORN,0),"^",2)
SET PSORX("NAME")=$PIECE(^DPT(DFN,0),"^")
+6 DO ICN^PSODPT(DFN)
+7 SET RX0=^PSRX(ORN,0)
SET RX2=$GET(^(2))
SET RX3=$GET(^(3))
+8 ; Deals with copay
IF $GET(DUZ("AG"))="V"
DO COPAY^PSOPTPST
+9 KILL ^TMP("PSOHDR",$JOB),^TMP("PSOPI",$JOB)
DO ^VADPT
DO ADD^VADPT
+10 SET ^TMP("PSOHDR",$JOB,1,0)=VADM(1)
SET ^TMP("PSOHDR",$JOB,2,0)=$PIECE(VADM(2),"^",2)
+11 SET ^TMP("PSOHDR",$JOB,3,0)=$PIECE(VADM(3),"^",2)
+12 SET ^TMP("PSOHDR",$JOB,4,0)=VADM(4)
SET ^TMP("PSOHDR",$JOB,5,0)=$PIECE(VADM(5),"^",2)
+13 SET POERR=1
DO RE^PSODEM
KILL POERR,VALMBCK
+14 SET ^TMP("PSOHDR",$JOB,6,0)=$SELECT($PIECE(WT,"^",8):$PIECE(WT,"^",9)_" ("_$PIECE(WT,"^")_")",1:"_______ (______)")
+15 SET ^TMP("PSOHDR",$JOB,7,0)=$SELECT($PIECE(HT,"^",8):$PIECE(HT,"^",9)_" ("_$PIECE(HT,"^")_")",1:"_______ (______)")
KILL VM,WT,HT
SET PSOHD=7
+16 SET ^TMP("PSOHDR",$JOB,9,0)=""
SET ^TMP("PSOHDR",$JOB,10,0)=""
+17 SET GMRA="0^0^111"
DO ^GMRADPT
SET ^TMP("PSOHDR",$JOB,8,0)=+$GET(GMRAL)
+18 DO NOW^%DTC
SET TM=$EXTRACT(%,1,12)
SET TM1=$PIECE(TM,".",2)
SET ^TMP("PSOBB",$JOB)=TM_"^"_TM1
+19 SET PSOLOUD=1
IF $PIECE($GET(^PS(55,PSODFN,0)),"^",6)'=2
DO EN^PSOHLUP(PSODFN)
KILL PSOLOUD
+20 SET PSOX=$GET(^PS(55,PSODFN,"PS"))
IF PSOX]""
SET PSORX("PATIENT STATUS")=$PIECE($GET(^PS(53,PSOX,0)),"^")
+21 DO CLEAR^VALM1
+22 SET STA="ACTIVE^NON-VERIFIED^REFILL^HOLD^NON-VERIFIED^SUSPENDED^^^^^^EXPIRED^DISCONTINUED^^DISCONTINUED^DISCONTINUED^HOLD"
+23 SET $PIECE(PSOLST(ORN),"^",3)=$PIECE(STA,"^",$PIECE(^PSRX(ORN,"STA"),"^")+1)
SET PSLST=ORN
SET ORD=1
+24 DO ACT^PSOORNE2
EOJ ;
+1 KILL INS1,HDR,IK,INDT,LOG,NODE,ORN,P1,PSI,PSL,PSOLION,PSNP,PSOACT,PSOBM,PSOCLC,PSOCNT,PSODD,PSODFN,PSOHD,PSOJ,PSOLST,PSOOI,PSOPF,PSLST
+2 KILL PSOIBQS,PSORLST,PSOSD,PSOSIG,PSPRXN,PSORX0,PSORX1,PTST,REFL,RF,RFD,RIFN,RLD,RPH,RTS,RX0,RX1,RX2,RX3,RXM,RXOR,SIG,SIGOK
+3 DO KVA^VADPT
KILL SLPPL,ST,STA,^TMP("PS",$JOB),PSOQFLG,PSORXED,PSOEDIT,DIR,DIRUT,DUOUT,DTOUT,PSOLOUD,GMRAL,GG,FEV,ACNT
+4 DO FULL^VALM1
KILL ^TMP("PSOAL",$JOB),^TMP("PSOAO",$JOB),^TMP("PSOSF",$JOB),^TMP("PSOPF",$JOB),^TMP("PSOPI",$JOB),^TMP("PSOPO",$JOB),^TMP("PSOHDR",$JOB),PAT
+5 KILL JJ,K,MM,PSDAYS,PSOAC,PSOAL,PSOCOU,PSOCOUU,PSONEW,PSODRUG,PSONOOR,PSRX0,QTY,REA,RFCNT,RFDT,RXDA,RXFL,RXREF,SUB,X,Z,ZII
+6 KILL ACOM,CRIT,DA,DDH,DGI,DGS,PSONEW3,SER,SERS,ZONE,RN,RXN,PSOX,PSOERR,ORD,PSOBCK,PSOBILL,SURX,PSORX("QFLG"),PSORX("FN"),CLOZPAT
+7 QUIT
LIST ;
+1 IF $GET(^PSRX(RXN,0))']""
WRITE !,$CHAR(7),"Rx data is not on file !",!
GOTO LISTX
+2 IF $PIECE(^PSRX(RXN,0),"^",15)=13
SET PSVD=1
WRITE !,$CHAR(7),"Rx # "_RXM_" has been deleted."
+3 SET RXN1=RXN
SET RXM1=RXM
IF '$GET(PSVD)
DO LST1
WRITE "."
SET RXN=RXN1
SET RXM=RXM1
KILL RXN1,RXM1
+4 ; IHS/CIA/PLS - 12/10/03 - Prevent UNDEF error from kill of RXN in LST1 subroutine
+5 ;F S RXN=$O(^PSRX("B",RXM,RXN)) Q:'RXN D
+6 FOR
SET RXN=$ORDER(^PSRX("B",RXM,$GET(RXN)))
IF 'RXN
QUIT
Begin DoDot:1
+7 IF $GET(^PSRX(RXN,0))']""
QUIT
+8 IF $PIECE(^PSRX(RXN,0),"^",15)=13
QUIT
+9 DO LST1
End DoDot:1
+10 KILL RXN1
GOTO LISTX
+11 QUIT
LST1 IF $GET(PSOLIST(1))']""
SET PSOLIST(1)=RXN_","
GOTO LISTX
+1 FOR PSOX1=0:0
SET PSOX1=$ORDER(PSOLIST(PSOX1))
IF 'PSOX1
QUIT
SET PSOX2=PSOX1
+2 IF $LENGTH(PSOLIST(PSOX2))+$LENGTH(RXN)<220
IF RXN_","'[PSOLIST(PSOX2)
SET PSOLIST(PSOX2)=PSOLIST(PSOX2)_RXN_","
+3 IF '$TEST
IF RXN_","'[PSOLIST(PSOX2+1)
SET PSOLIST(PSOX2+1)=RXN_","
LISTX KILL PSOX1,PSOX2,RXN,PSVD
+1 QUIT
