PSORXL ;BHAM ISC/SAB - action to be taken on prescriptions ;28-Mar-2013 16:45;DU
;;7.0;OUTPATIENT PHARMACY;**8,21,24,32,47,135,1008,1013,148,287,1015**;DEC 1997;Build 62
;External reference to File #50 supported by DBIA 221
;External references CHPUS^IBACUS and TRI^IBACUS supported by DBIA 2030
; Modified - IHS/CIA/PLS - 12/23/2003 - Line QLBL+2 and P1
; IHS/MSC/PLS - 04/30/2009 - Line PSORXL+12
; - 11/04/2011 - Line PSORXL+9
I $G(PSOTRVV),$G(PPL) S PSORX("PSOL",1)=PPL K PPL
N SLBL,PSOSONE,PSOKLRXS
N APSPPRIO
D APRTY^APSPFUNC
; IHS/CIA/PLS - 03/24/04 - Removed conditional call to label prompt
;S:'$G(PPL) PPL=$G(PSORX("PSOL",1)) G:$P(PSOPAR,"^",26) P
S:'$G(PPL) PPL=$G(PSORX("PSOL",1))
D SAVEPRI(PPL) ;IHS/MSC/PLS - 11/04/11 - P13
I '$$GET1^DIQ(9009033,+$G(PSOSITE),316,"I") D ^APSPNE4 Q ; IHS/CIA/PLS - 01/18/04 - Call IHS Label prompt
D CHKFDT^APSPFUNC(.PPL) S PSORX("PSOL",1)=PPL ;IHS/MSC/PLS - 04/30/09 - Remove RXs with future fill dates
I 'PPL,'$D(RXRS) D Q
.W !!,"No other labels to print. Exiting..."
LBL ;
I $G(PPL) N PSOCKDC S PSOCKDC=1 D ECME^PSORXL1 I '$G(PPL) S PPL="" Q ;don't prompt to print labels for DC'ed Rx's
W !! S DIR("A",1)="Label Printer: "_$S($G(SUSPT):PSLION,1:$G(PSOLAP))
S DIR("A")="LABEL: QUEUE/CHANGE PRINTER"_$S($P(PSOPAR,"^",23):"/HOLD",1:"")_$S($P(PSOPAR,"^",24):"/SUSPEND",1:"")_$S($P(PSOPAR,"^",26):"/LABEL",1:"")_" or '^' to bypass "
S DIR("?",1)="Enter 'Q' to queue labels to print",DIR("?")="Enter '^' to bypass label functions",DIR("?",4)="Enter 'S' to suspend labels to print later"
S DIR("?",2)="Enter 'H' to hold label until Rx can be filled",DIR("?",3)="Enter 'P' for Rx profile"
S DIR("?",5)="Enter 'C' to select another label printer"
S:$P(PSOPAR,"^",26) DIR("?",5)="Enter 'L' to print labels without queuing"
TRI ;Tricare
S X="IBACUS" X ^%ZOSF("TEST") K X I '$T G PASS
I '$$TRI^IBACUS() G PASS
I '$D(PSORX("PSOL",1))!($G(PSOSUREP))!($G(PSOEXREP)) G PASS
N GGG,PBILL,PSTRD,PSTRDZ,PSTRF,PSTRP,TRXI,TRIRX,PSTRIVAR,VV,VVV,VVCT
D DEV^PSOCPTRI
K ^TMP($J,"PSONOB"),^TMP($J,"PSOBILL")
S VVCT=0 F VV=0:0 S VV=$O(PSORX("PSOL",VV)) Q:'VV F VVV=1:1 S TRXI=$P(PSORX("PSOL",VV),",",VVV) Q:'TRXI D
.I '$G(DT) S DT=$$DT^XLFDT
.I $P($G(^PSRX(+TRXI,"STA")),"^")=3 Q
.S PSTRP=$P($G(^PSRX(+TRXI,0)),"^",2),PSTRD=+$G(PSOSITE),PSTRDZ=+$G(DUZ)
.S PSTRF=0 F GGG=0:0 S GGG=$O(^PSRX(+TRXI,1,GGG)) Q:'GGG S PSTRF=GGG
.S VVCT=VVCT+1
.I $G(RXRP(TRXI))!($G(RXPR(TRXI)))!($G(RXRH(TRXI))) S ^TMP($J,"PSONOB",VVCT)=TRXI Q
.S PBILL=$$CHPUS^IBACUS(PSTRP,DT,TRXI,PSTRF,PSOLAP,PSTRD,PSTRDZ) S ^TMP($J,$S($G(PBILL):"PSOBILL",1:"PSONOB"),VVCT)=TRXI
I '$D(^TMP($J,"PSOBILL")) K ^TMP($J,"PSONOB") G PASS
I '$D(^TMP($J,"PSONOB")),$D(^TMP($J,"PSOBILL")) S (Y,LBL)="H" G H1
;If some Rx's are billable, and some are not
SETP K PSORX("PSOL"),PPL S VVCT=1 F VV=0:0 S VV=$O(^TMP($J,$S($G(PSTRIVAR):"PSONOB",1:"PSOBILL"),VV)) Q:'VV S TRIRX=^TMP($J,$S($G(PSTRIVAR):"PSONOB",1:"PSOBILL"),VV) I +TRIRX D
.I $G(PSORX("PSOL",1))="" S PSORX("PSOL",1)=TRIRX_"," Q
.I $L(PSORX("PSOL",VVCT))+$L(TRIRX)<220 S PSORX("PSOL",VVCT)=PSORX("PSOL",VVCT)_TRIRX_"," Q
.S VVCT=VVCT+1 S PSORX("PSOL",VVCT)=TRIRX_","
I '$G(PSTRIVAR) S (Y,LBL)="H" S PSOKLRXS=1 K PSORSAVE,PSOPSAVE,PSOHSAVE D RSAVE D H1 D RREST K PSORSAVE,PSOPSAVE,PSOHSAVE K PSOKLRXS S PSTRIVAR=1 G SETP
K ^TMP($J,"PSONOB") S PPL=$G(PSORX("PSOL",1))
PASS ;
I $E($G(DIR("A")),1,6)'="LABEL:" D RESDIR^PSOCPTRI
S DIR(0)="SA^P:PROFILE;Q:QUEUE;C:CHANGE PRINTER"_$S($P(PSOPAR,"^",23):";H:HOLD",1:"")_$S($P(PSOPAR,"^",24):";S:SUSPENSE",1:"")_$S($P(PSOPAR,"^",26):";L:PRINT",1:""),DIR("B")="Q" D ^DIR D G:$D(DIRUT)!($D(DUOUT)) EX
.I $D(DIRUT)!($D(DUOUT)) D AL^PSOLBL("UT") I $G(PSOEXREP) S PSOEXREX=1
.I $G(PSOPULL) I $D(DIRUT)!($D(DUOUT)) S PSOQFLAG=1
S:$G(PSOBEDT) NOPP=Y
I $G(Y)="C" K PSOCLBL,%ZIS("B") S PSOCLBL=1 D @$S('$D(PSOPAR):"^PSOLSET",1:"PLBL^PSOLSET") K PSOCLBL G LBL
I $G(Y)="Q",$D(RXRS),'$G(PSOPULL) D PPLADD^PSOSUPOE
I $G(PSXSYS),($G(Y)'="H"),($G(Y)'="P"),('$G(PSOEXREP)) S LBL=Y,(RXLTOP,PPL1)=1 S:'$G(PSOPULL) SLBL=Y D A^PSOCMOP G:'$G(PPL) D1
K DIR S LBL=Y S:'$G(PSOPULL) SLBL=Y G Q:Y="Q",S:Y="S",H1:Y="H",P:Y="L" I Y="P" W ! S PSDFN=DFN,PSFROM="" D ^PSODSPL K PSDFN,PSFROM G LBL
EX I $D(DUOUT)!$D(DIRUT) K BINGCRT,BINGRTE,BBRX,BBFLG S:$D(RXRS) SLBL="^" G:$D(RXRS) RXS K DIR,X,DIRUT,DUOUT,ACT,Y,DTOUT,PPL,REPRINT S NOBG=1 Q
Q S PPL1=1 G:$G(PPL)']"" D1 S PSNP=0,PSL=1 D I $G(PSOFROM)="NEW",$P(PSOPAR,"^",8) S PSNP=1
.Q:'$P(PSOPAR,"^",8)!($G(PSONOPRT))
.F SLPPL=0:0 S SLPPL=$O(RXRS(SLPPL)) Q:'SLPPL!($G(PSNP)) I '$O(^PSRX(SLPPL,1,0)),'$D(RXPR(SLPPL)) S PSNP=1
I $G(PSOLAP)]"",$G(PSOLAP)'=ION G QLBL
Q1 W ! K POP S %ZIS("B")="",%ZIS="MNQ",%ZIS("A")="Select LABEL DEVICE: " D ^%ZIS S PSLION=ION K %ZIS("A") Q:$G(POP)&($G(PSPARTXX)) G:$G(POP)&($G(PSOSONE)) RXSQ D:$G(POP)&($G(PSONOPRT)) Q:$G(PSOQFLAG) G:POP!(IO=IO(0)) LBL S PSOLAP=ION
.S PSOQFLAG=1
N PSOIOS S PSOIOS=IOS D DEVBAR^PSOBMST
S PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$P(PSOPAR,"^",10)
D ^%ZISC S PSL=0
QLBL I $G(PSXSYS),('$G(RXLTOP)),('$G(PSOEXREP)) D RXL^PSOCMOP G:'$G(PPL) D1
;
;- Submitting list of Rx to ECME for DUR/79 REJECT check and possible submission to 3rd Pary Payer
D ECME^PSORXL1 I '$G(PPL) W !!,"No Label(s) printed.",!! S PSOQFLAG=1 Q
;
; IHS/CIA/PLS - 12/23/2003 - Direct to IHS label routine
;S ZTRTN="DQ^PSOLBL",ZTIO=$S($G(SUSPT):PSLION,1:PSOLAP),ZTDESC="Outpatient Pharmacy "_$S($G(SUSPT):"SUSPENSE ",$G(DG):"DRUG INTERACTION ",1:"")_"LABELS OUTPUT ROUTINE",ZTDTH=$S($G(PSOTIME):PSOTIME,1:$H),PDUZ=DUZ
S ZTRTN="DQ^APSPLBL",ZTIO=$S($G(SUSPT):PSLION,1:PSOLAP),ZTDESC="Outpatient Pharmacy "_$S($G(SUSPT):"SUSPENSE ",$G(DG):"DRUG INTERACTION ",1:"")_"LABELS OUTPUT ROUTINE",ZTDTH=$S($G(PSOTIME):PSOTIME,1:$H),PDUZ=DUZ
F G="PPL1","PSOSYS","DFN","PSOPAR","PDUZ","PCOMX",$S($G(SUSPT):"PFION",1:"PSOLAP"),"PPL","PSOSITE","RXY","COPIES","SIDE","PSOSUSPR","PSOBARS","PSOBAR1","PSOBAR0","PSODELE","PSOPULL","PSTAT","PSODBQ","PSOEXREP","PSOTREP" S:$D(@G) ZTSAVE(G)=""
; IHS/CIA/PLS - 12/23/03 - Save additional variables
F G="%APSITE","APSPMAN","APSPZRP","DUZ","PSOFROM","%APSITE","APSQSGLB","APSPREIS" S:$D(@G) ZTSAVE(G)=""
S ZTSAVE("P*")=""
S ZTSAVE("PSORX(")="",ZTSAVE("RXRP(")="",ZTSAVE("RXPR(")="",ZTSAVE("RXRS(")="",ZTSAVE("RXFL(")="",ZTSAVE("PCOMH(")=""
D ^%ZISC,^%ZTLOAD K:$G(PSOSONE) RXRS W:$D(ZTSK)&('$G(SUSPT))&('$G(PSOEXREP)) !!,"LABEL(S) QUEUED TO PRINT",!!
Q:$G(PSPARTXX) K G,PDUZ K:'$G(SUSPT) ZTSK Q:$G(DG)
G:'$G(PSNP) QUEUP G:$G(PSOPRFLG) QUEUP S HOLDRPAS=$G(PSOPRPAS),PSOPRPAS=$P(PSOPAR,"^",13)
PLBL S PSOION=ION
I '$D(PSOPROP)!($G(PSOPROP)=ION) W $C(7),!,"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") G:POP QUEUP G:$E(IOST)["C"!(PSOION=ION) PLBL S PSOPROP=ION
QPRF S ZTRTN="DQ^PSOPRF",ZTIO=PSOPROP,ZTDESC="Outpatient Pharmacy "_$S($G(SUSPT):"SUSPENSE ",1:"")_"PATIENT PROFILES",ZTDTH=$S($G(PSOTIME):PSOTIME,1:$H)
F G="PSOPAR","PSODTCUT","PSOPRPAS","DFN","PSOSITE","NEW1","NEW11","PSOBMST","PFIO","PPL" S:$D(@G) ZTSAVE(G)=""
D ^%ZTLOAD W:$D(ZTSK)&('$G(SUSPT))&('$G(PSOEXREP)) !,"PROFILE IS QUEUED TO PRINT",!! K G K:'$G(SUSPT) ZTSK D ^%ZISC
QUEUP D:$G(POP)&($G(PSONOPRT)) Q:$G(PSOQFLAG) S PSNP=0,PSOPRPAS=$G(HOLDRPAS) K:PSOPRPAS']"" PSOPRPAS K HOLDRPAS G D1
.S PSOQFLAG=1
Q
;
S G S^PSORXL1
SUS S X="IBACUS" X ^%ZOSF("TEST") K X I '$T G SUSL1
N TRIDA S TRIDA=DA I '$$TRI^IBACUS() S DA=TRIDA G SUSL1
I $G(RXRP(TRIDA))!($G(RXPR(TRIDA)))!($G(RXRH(TRIDA))) S DA=TRIDA G SUSL1
N PBILL,PSTRD,PSTRDZ,PSTRF,PSTRP,GGG
D DEV^PSOCPTRI
I '$G(DT) S DT=$$DT^XLFDT
S PSTRP=$P($G(^PSRX(+TRIDA,0)),"^",2),PSTRD=+$G(PSOSITE),PSTRDZ=+$G(DUZ)
S PSTRF=0 F GGG=0:0 S GGG=$O(^PSRX(+TRIDA,1,GGG)) Q:'GGG S PSTRF=GGG
S PBILL=$$CHPUS^IBACUS(PSTRP,DT,TRIDA,PSTRF,PSOLAP,PSTRD,PSTRDZ)
I '$G(PBILL) S DA=TRIDA G SUSL1
S FLD(99)="99",FLD(99.1)="Awaiting CHAMPUS billing approval"
N RSDT,ACT,PSUS,RXF,RFN,I,PSDA,NOW,IR,FDA
S DA=TRIDA D H^PSOCPTRH
Q
SUSL1 G SUS^PSORXL1
H1 S PPL1=1 S:'$G(PPL) PPL=$G(PSORX("PSOL",PPL1))
D:'$D(^TMP($J,"PSOBILL")) NOOR^PSOHLD I $D(DIRUT) K DIRUT G PSORXL
I $D(^TMP($J,"PSOBILL")) S FLD(99)="99",FLD(99.1)="Awaiting CHAMPUS billing approval" G H
G:$G(PPL)']"" D1 D FLD^PSOHLD I $D(DUOUT)!($D(DIRUT)) K DIRUT,DUOUT,FLD,DIR G LBL
H K SPPL G:$D(DTOUT) D1 S SPPL="" F PI=1:1 Q:$P(PPL,",",PI)="" D
.S DA=$P(PPL,",",PI) I $P(^PSRX(DA,"STA"),"^")<10,$P(^("STA"),"^")'=4 D @$S($D(^TMP($J,"PSOBILL")):"H^PSOCPTRH",1:"H^PSOHLD") Q
.I $P(^PSRX(DA,"STA"),"^")=4 S SPPL=SPPL_DA_"," Q
I $G(SPPL)]"" D
.W !!,$C(7),"Drug Interaction Rx(s) " F I=1:1 Q:$P(SPPL,",",I)="" W $P(^PSRX($P(SPPL,",",I),0),"^")_", "
.S PPL=SPPL,DG=1 D Q K DG,SPPL
D1 K RXLTOP I $G(PPL1),$O(PSORX("PSOL",$G(PPL1))) S PPL1=$O(PSORX("PSOL",PPL1)),PPL=PSORX("PSOL",PPL1) G @$S(LBL="H":"H",LBL="L":"P1",1:"QLBL")
RXS I $D(RXRS),'$G(PSOKLRXS) I $G(SLBL)="H"!($G(SLBL)="S")!($G(SLBL)="^")!($G(SLBL)="") D G:$G(PPL)'="" Q
.K PPL,PSORX("PSOL") S PSOSONE=1 D PPLADD^PSOSUPOE
.Q:$G(PPL)="" W !!,"You have selected the following Rx(s) to be pulled from suspense:",!
.F RXSS=0:0 S RXSS=$O(RXRS(RXSS)) Q:'RXSS W !," Rx # ",$P($G(^PSRX(+$G(RXSS),0)),"^"),?23,$P($G(^PSDRUG(+$P($G(^PSRX(+$G(RXSS),0)),"^",6),0)),"^")
.K DIR W ! S DIR(0)="Y",DIR("B")="YES",DIR("A")="Do you still want to pull these Rx(s) from suspense" D ^DIR K DIR I Y'=1 W !!,"Rx(s) will remain in Suspense!",! D RESET^PSOSUPOE K RXRS,PPL
K:'$G(PSOKLRXS) RXRS K ^TMP($J,"PSOBILL"),RXPR,RXRP,RXRH,RXSS,LBL,PPL1,PPL,DIR,%DT,%,SD,COUNT,EXDT,L,PDUZ,REF,REPRINT,RFDATE,RFL1,RFLL,RXN,WARN,ZY,FLD,PI,ZD,ACT,X,Y,DIRUT,DUOUT,DTOUT,DIROUT Q
P S PPL1=1 S:'$G(PPL) PPL=$G(PSORX("PSOL",1)) G:$G(PPL)']"" D1
I $G(PSOLAP)']"" W ! K POP,ZTSK S %ZIS="M",%ZIS("A")="Select LABEL DEVICE: " D ^%ZIS K %ZIS("A") G:POP LBL S PSOLAP=ION
PZ S IOP=PSOLAP D ^%ZIS ; IHS/CIA/PLS - 12/23/03 - PZ line label added
I POP W !,"The label printer is busy, do you want to wait? " S %=1 D YN^DICN K POP Q:%=2 K %,%Y G PZ ; IHS/CIA/PLS - 12/23/03 Wait for busy printer prompt.
N PSOIOS S PSOIOS=IOS D DEVBAR^PSOBMST
P1 ; IHS/CIA/PLS - 12/23/03 - Call IHS Label routine
;S PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$P(PSOPAR,"^",10),PDUZ=DUZ D DQ1^PSOLBL,^%ZISC
S PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$P(PSOPAR,"^",10),PDUZ=DUZ D DQ1^APSPLBL,^%ZISC
G:'$P(PSOPAR,"^",8)!(+$G(REPRINT))!($G(PSOFROM)'="NEW") D1 I $G(PSOPROP)']"" S PSOION=ION,%ZIS="M",%ZIS("A")="Select PROFILE DEVICE: " D ^%ZIS K %ZIS("A") G:POP D1 S PSOPROP=ION
S IOP=PSOPROP D ^%ZIS D DQ^PSOPRF,^%ZISC G D1
Q
RXSQ K RXRS G RXS
Q
RSAVE N PMX
S PMX="" F S PMX=$O(RXRP(PMX)) Q:PMX="" S PSORSAVE(PMX)=RXRP(PMX)
S PMX="" F S PMX=$O(RXPR(PMX)) Q:PMX="" S PSOPSAVE(PMX)=RXPR(PMX)
S PMX="" F S PMX=$O(RXRH(PMX)) Q:PMX="" S PSOHSAVE(PMX)=RXRH(PMX)
Q
RREST N PMXZ
S PMXZ="" F S PMXZ=$O(PSORSAVE(PMXZ)) Q:PMXZ="" S RXRP(PMXZ)=PSORSAVE(PMXZ)
S PMXZ="" F S PMXZ=$O(PSOPSAVE(PMXZ)) Q:PMXZ="" S RXPR(PMXZ)=PSOPSAVE(PMXZ)
S PSMX="" F S PMXZ=$O(PSOHSAVE(PMXZ)) Q:PMXZ="" S RXRH(PMXZ)=PSOHSAVE(PMXZ)
Q
; Store Fill Priority
SAVEPRI(RXS) ;EP-
N PPLARY,RX,LFN
Q:'$L($G(RXS))
D BPPLARY^APSPFUNC(RXS)
S RX=0
F S RX=$O(PPLARY(RX)) Q:'RX D
.Q:'$D(^PSRX(RX,0))
.S LFN=+$O(^(1,$C(1)),-1)
.I LFN D ;Refill
..S $P(^PSRX(RX,1,LFN,9999999),U,18)=APSPPRIO
.E D ;
..S $P(^PSRX(RX,999999931),U,8)=APSPPRIO
Q
PSORXL ;BHAM ISC/SAB - action to be taken on prescriptions ;28-Mar-2013 16:45;DU
+1 ;;7.0;OUTPATIENT PHARMACY;**8,21,24,32,47,135,1008,1013,148,287,1015**;DEC 1997;Build 62
+2 ;External reference to File #50 supported by DBIA 221
+3 ;External references CHPUS^IBACUS and TRI^IBACUS supported by DBIA 2030
+4 ; Modified - IHS/CIA/PLS - 12/23/2003 - Line QLBL+2 and P1
+5 ; IHS/MSC/PLS - 04/30/2009 - Line PSORXL+12
+6 ; - 11/04/2011 - Line PSORXL+9
+7 IF $GET(PSOTRVV)
IF $GET(PPL)
SET PSORX("PSOL",1)=PPL
KILL PPL
+8 NEW SLBL,PSOSONE,PSOKLRXS
+9 NEW APSPPRIO
+10 DO APRTY^APSPFUNC
+11 ; IHS/CIA/PLS - 03/24/04 - Removed conditional call to label prompt
+12 ;S:'$G(PPL) PPL=$G(PSORX("PSOL",1)) G:$P(PSOPAR,"^",26) P
+13 IF '$GET(PPL)
SET PPL=$GET(PSORX("PSOL",1))
+14 ;IHS/MSC/PLS - 11/04/11 - P13
DO SAVEPRI(PPL)
+15 ; IHS/CIA/PLS - 01/18/04 - Call IHS Label prompt
IF '$$GET1^DIQ(9009033,+$GET(PSOSITE),316,"I")
DO ^APSPNE4
QUIT
+16 ;IHS/MSC/PLS - 04/30/09 - Remove RXs with future fill dates
DO CHKFDT^APSPFUNC(.PPL)
SET PSORX("PSOL",1)=PPL
+17 IF 'PPL
IF '$DATA(RXRS)
Begin DoDot:1
+18 WRITE !!,"No other labels to print. Exiting..."
End DoDot:1
QUIT
LBL ;
+1 ;don't prompt to print labels for DC'ed Rx's
IF $GET(PPL)
NEW PSOCKDC
SET PSOCKDC=1
DO ECME^PSORXL1
IF '$GET(PPL)
SET PPL=""
QUIT
+2 WRITE !!
SET DIR("A",1)="Label Printer: "_$SELECT($GET(SUSPT):PSLION,1:$GET(PSOLAP))
+3 SET DIR("A")="LABEL: QUEUE/CHANGE PRINTER"_$SELECT($PIECE(PSOPAR,"^",23):"/HOLD",1:"")_$SELECT($PIECE(PSOPAR,"^",24):"/SUSPEND",1:"")_$SELECT($PIECE(PSOPAR,"^",26):"/LABEL",1:"")_" or '^' to bypass "
+4 SET DIR("?",1)="Enter 'Q' to queue labels to print"
SET DIR("?")="Enter '^' to bypass label functions"
SET DIR("?",4)="Enter 'S' to suspend labels to print later"
+5 SET DIR("?",2)="Enter 'H' to hold label until Rx can be filled"
SET DIR("?",3)="Enter 'P' for Rx profile"
+6 SET DIR("?",5)="Enter 'C' to select another label printer"
+7 IF $PIECE(PSOPAR,"^",26)
SET DIR("?",5)="Enter 'L' to print labels without queuing"
TRI ;Tricare
+1 SET X="IBACUS"
XECUTE ^%ZOSF("TEST")
KILL X
IF '$TEST
GOTO PASS
+2 IF '$$TRI^IBACUS()
GOTO PASS
+3 IF '$DATA(PSORX("PSOL",1))!($GET(PSOSUREP))!($GET(PSOEXREP))
GOTO PASS
+4 NEW GGG,PBILL,PSTRD,PSTRDZ,PSTRF,PSTRP,TRXI,TRIRX,PSTRIVAR,VV,VVV,VVCT
+5 DO DEV^PSOCPTRI
+6 KILL ^TMP($JOB,"PSONOB"),^TMP($JOB,"PSOBILL")
+7 SET VVCT=0
FOR VV=0:0
SET VV=$ORDER(PSORX("PSOL",VV))
IF 'VV
QUIT
FOR VVV=1:1
SET TRXI=$PIECE(PSORX("PSOL",VV),",",VVV)
IF 'TRXI
QUIT
Begin DoDot:1
+8 IF '$GET(DT)
SET DT=$$DT^XLFDT
+9 IF $PIECE($GET(^PSRX(+TRXI,"STA")),"^")=3
QUIT
+10 SET PSTRP=$PIECE($GET(^PSRX(+TRXI,0)),"^",2)
SET PSTRD=+$GET(PSOSITE)
SET PSTRDZ=+$GET(DUZ)
+11 SET PSTRF=0
FOR GGG=0:0
SET GGG=$ORDER(^PSRX(+TRXI,1,GGG))
IF 'GGG
QUIT
SET PSTRF=GGG
+12 SET VVCT=VVCT+1
+13 IF $GET(RXRP(TRXI))!($GET(RXPR(TRXI)))!($GET(RXRH(TRXI)))
SET ^TMP($JOB,"PSONOB",VVCT)=TRXI
QUIT
+14 SET PBILL=$$CHPUS^IBACUS(PSTRP,DT,TRXI,PSTRF,PSOLAP,PSTRD,PSTRDZ)
SET ^TMP($JOB,$SELECT($GET(PBILL):"PSOBILL",1:"PSONOB"),VVCT)=TRXI
End DoDot:1
+15 IF '$DATA(^TMP($JOB,"PSOBILL"))
KILL ^TMP($JOB,"PSONOB")
GOTO PASS
+16 IF '$DATA(^TMP($JOB,"PSONOB"))
IF $DATA(^TMP($JOB,"PSOBILL"))
SET (Y,LBL)="H"
GOTO H1
+17 ;If some Rx's are billable, and some are not
SETP KILL PSORX("PSOL"),PPL
SET VVCT=1
FOR VV=0:0
SET VV=$ORDER(^TMP($JOB,$SELECT($GET(PSTRIVAR):"PSONOB",1:"PSOBILL"),VV))
IF 'VV
QUIT
SET TRIRX=^TMP($JOB,$SELECT($GET(PSTRIVAR):"PSONOB",1:"PSOBILL"),VV)
IF +TRIRX
Begin DoDot:1
+1 IF $GET(PSORX("PSOL",1))=""
SET PSORX("PSOL",1)=TRIRX_","
QUIT
+2 IF $LENGTH(PSORX("PSOL",VVCT))+$LENGTH(TRIRX)<220
SET PSORX("PSOL",VVCT)=PSORX("PSOL",VVCT)_TRIRX_","
QUIT
+3 SET VVCT=VVCT+1
SET PSORX("PSOL",VVCT)=TRIRX_","
End DoDot:1
+4 IF '$GET(PSTRIVAR)
SET (Y,LBL)="H"
SET PSOKLRXS=1
KILL PSORSAVE,PSOPSAVE,PSOHSAVE
DO RSAVE
DO H1
DO RREST
KILL PSORSAVE,PSOPSAVE,PSOHSAVE
KILL PSOKLRXS
SET PSTRIVAR=1
GOTO SETP
+5 KILL ^TMP($JOB,"PSONOB")
SET PPL=$GET(PSORX("PSOL",1))
PASS ;
+1 IF $EXTRACT($GET(DIR("A")),1,6)'="LABEL:"
DO RESDIR^PSOCPTRI
+2 SET DIR(0)="SA^P:PROFILE;Q:QUEUE;C:CHANGE PRINTER"_$SELECT($PIECE(PSOPAR,"^",23):";H:HOLD",1:"")_$SELECT($PIECE(PSOPAR,"^",24):";S:SUSPENSE",1:"")_$SELECT($PIECE(PSOPAR,"^",26):";L:PRINT",1:"")
SET DIR("B")="Q"
DO ^DIR
Begin DoDot:1
+3 IF $DATA(DIRUT)!($DATA(DUOUT))
DO AL^PSOLBL("UT")
IF $GET(PSOEXREP)
SET PSOEXREX=1
+4 IF $GET(PSOPULL)
IF $DATA(DIRUT)!($DATA(DUOUT))
SET PSOQFLAG=1
End DoDot:1
IF $DATA(DIRUT)!($DATA(DUOUT))
GOTO EX
+5 IF $GET(PSOBEDT)
SET NOPP=Y
+6 IF $GET(Y)="C"
KILL PSOCLBL,%ZIS("B")
SET PSOCLBL=1
DO @$SELECT('$DATA(PSOPAR):"^PSOLSET",1:"PLBL^PSOLSET")
KILL PSOCLBL
GOTO LBL
+7 IF $GET(Y)="Q"
IF $DATA(RXRS)
IF '$GET(PSOPULL)
DO PPLADD^PSOSUPOE
+8 IF $GET(PSXSYS)
IF ($GET(Y)'="H")
IF ($GET(Y)'="P")
IF ('$GET(PSOEXREP))
SET LBL=Y
SET (RXLTOP,PPL1)=1
IF '$GET(PSOPULL)
SET SLBL=Y
DO A^PSOCMOP
IF '$GET(PPL)
GOTO D1
+9 KILL DIR
SET LBL=Y
IF '$GET(PSOPULL)
SET SLBL=Y
IF Y="Q"
GOTO Q
IF Y="S"
GOTO S
IF Y="H"
GOTO H1
IF Y="L"
GOTO P
IF Y="P"
WRITE !
SET PSDFN=DFN
SET PSFROM=""
DO ^PSODSPL
KILL PSDFN,PSFROM
GOTO LBL
EX IF $DATA(DUOUT)!$DATA(DIRUT)
KILL BINGCRT,BINGRTE,BBRX,BBFLG
IF $DATA(RXRS)
SET SLBL="^"
IF $DATA(RXRS)
GOTO RXS
KILL DIR,X,DIRUT,DUOUT,ACT,Y,DTOUT,PPL,REPRINT
SET NOBG=1
QUIT
Q SET PPL1=1
IF $GET(PPL)']""
GOTO D1
SET PSNP=0
SET PSL=1
Begin DoDot:1
+1 IF '$PIECE(PSOPAR,"^",8)!($GET(PSONOPRT))
QUIT
+2 FOR SLPPL=0:0
SET SLPPL=$ORDER(RXRS(SLPPL))
IF 'SLPPL!($GET(PSNP))
QUIT
IF '$ORDER(^PSRX(SLPPL,1,0))
IF '$DATA(RXPR(SLPPL))
SET PSNP=1
End DoDot:1
IF $GET(PSOFROM)="NEW"
IF $PIECE(PSOPAR,"^",8)
SET PSNP=1
+3 IF $GET(PSOLAP)]""
IF $GET(PSOLAP)'=ION
GOTO QLBL
Q1 WRITE !
KILL POP
SET %ZIS("B")=""
SET %ZIS="MNQ"
SET %ZIS("A")="Select LABEL DEVICE: "
DO ^%ZIS
SET PSLION=ION
KILL %ZIS("A")
IF $GET(POP)&($GET(PSPARTXX))
QUIT
IF $GET(POP)&($GET(PSOSONE))
GOTO RXSQ
IF $GET(POP)&($GET(PSONOPRT))
Begin DoDot:1
+1 SET PSOQFLAG=1
End DoDot:1
IF $GET(PSOQFLAG)
QUIT
IF POP!(IO=IO(0))
GOTO LBL
SET PSOLAP=ION
+2 NEW PSOIOS
SET PSOIOS=IOS
DO DEVBAR^PSOBMST
+3 SET PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$PIECE(PSOPAR,"^",10)
+4 DO ^%ZISC
SET PSL=0
QLBL IF $GET(PSXSYS)
IF ('$GET(RXLTOP))
IF ('$GET(PSOEXREP))
DO RXL^PSOCMOP
IF '$GET(PPL)
GOTO D1
+1 ;
+2 ;- Submitting list of Rx to ECME for DUR/79 REJECT check and possible submission to 3rd Pary Payer
+3 DO ECME^PSORXL1
IF '$GET(PPL)
WRITE !!,"No Label(s) printed.",!!
SET PSOQFLAG=1
QUIT
+4 ;
+5 ; IHS/CIA/PLS - 12/23/2003 - Direct to IHS label routine
+6 ;SORXL_source.html#xS">SORXL_source.html#xSORXL_source.html#xS">S">SORXL_source.html#xS">S ZTRTN="DQ^PSORXL_source.html#xS">SORXL_source.html#xSORXL_source.html#xS">S">SORXL_source.html#xS">SOLBL",ZTIO=$SORXL_source.html#xS">SORXL_source.html#xSORXL_source.html#xS">S">SORXL_source.html#xS">S($G(SORXL_source.html#xS">SORXL_source.html#xSORXL_source.html#xS">S">SORXL_source.html#xS">SUSORXL_source.html#xS">SORXL_source.html#xSORXL_source.html#xS">S">SORXL_source.html#xS">SPT):PSORXL_source.html#xS">SORXL_source.html#xSORXL_source.html#xS">S">SORXL_source.html#xS">SLION,1:PSORXL_source.html#xS">SORXL_source.html#xSORXL_source.html#xS">S">SORXL_source.html#xS">SOLAP),ZTDESORXL_source.html#xS">SORXL_source.html#xSORXL_source.html#xS">S">SORXL_source.html#xS">SC="Outpatient Pharmacy "_$SORXL_source.html#xS">SORXL_source.html#xSORXL_source.html#xS">S">SORXL_source.html#xS">S($G(SORXL_source.html#xS">SORXL_source.html#xSORXL_source.html#xS">S">SORXL_source.html#xS">SUSORXL_source.html#xS">SORXL_source.html#xSORXL_source.html#xS">S">SORXL_source.html#xS">SPT):"SORXL_source.html#xS">SORXL_source.html#xSORXL_source.html#xS">S">SORXL_source.html#xS">SUSORXL_source.html#xS">SORXL_source.html#xSORXL_source.html#xS">S">SORXL_source.html#xS">SPENSORXL_source.html#xS">SORXL_source.html#xSORXL_source.html#xS">S">SORXL_source.html#xS">SE ",$G(DG):"DRUG INTERACTION ",1:"")_"LABELSORXL_source.html#xS">SORXL_source.html#xSORXL_source.html#xS">S">SORXL_source.html#xS">S OUTPUT ROUTINE",ZTDTH=$SORXL_source.html#xS">SORXL_source.html#xSORXL_source.html#xS">S">SORXL_source.html#xS">S($G(PSORXL_source.html#xS">SORXL_source.html#xSORXL_source.html#xS">S">SORXL_source.html#xS">SOTIME):PSORXL_source.html#xS">SORXL_source.html#xSORXL_source.html#xS">S">SORXL_source.html#xS">SOTIME,1:$H),PDUZ=DUZ
+7 SET ZTRTN="DQ^APSPLBL"
SET ZTIO=$SELECT($GET(SUSPT):PSLION,1:PSOLAP)
SET ZTDESC="Outpatient Pharmacy "_$SELECT($GET(SUSPT):"SUSPENSE ",$GET(DG):"DRUG INTERACTION ",1:"")_"LABELS OUTPUT ROUTINE"
SET ZTDTH=$SELECT($GET(PSOTIME):PSOTIME,1:$HOROLOG)
SET PDUZ=DUZ
+8 FOR G="PPL1","PSOSYS","DFN","PSOPAR","PDUZ","PCOMX",$SELECT($GET(SUSPT):"PFION",1:"PSOLAP"),"PPL","PSOSITE","RXY","COPIES","SIDE","PSOSUSPR","PSOBARS","PSOBAR1","PSOBAR0","PSODELE","PSOPULL","PSTAT","PSODBQ","PSOEXREP","PSOTREP"
IF $DATA(@G)
SET ZTSAVE(G)=""
+9 ; IHS/CIA/PLS - 12/23/03 - Save additional variables
+10 FOR G="%APSITE","APSPMAN","APSPZRP","DUZ","PSOFROM","%APSITE","APSQSGLB","APSPREIS"
IF $DATA(@G)
SET ZTSAVE(G)=""
+11 SET ZTSAVE("P*")=""
+12 SET ZTSAVE("PSORX(")=""
SET ZTSAVE("RXRP(")=""
SET ZTSAVE("RXPR(")=""
SET ZTSAVE("RXRS(")=""
SET ZTSAVE("RXFL(")=""
SET ZTSAVE("PCOMH(")=""
+13 DO ^%ZISC
DO ^%ZTLOAD
IF $GET(PSOSONE)
KILL RXRS
IF $DATA(ZTSK)&('$GET(SUSPT))&('$GET(PSOEXREP))
WRITE !!,"LABEL(S) QUEUED TO PRINT",!!
+14 IF $GET(PSPARTXX)
QUIT
KILL G,PDUZ
IF '$GET(SUSPT)
KILL ZTSK
IF $GET(DG)
QUIT
+15 IF '$GET(PSNP)
GOTO QUEUP
IF $GET(PSOPRFLG)
GOTO QUEUP
SET HOLDRPAS=$GET(PSOPRPAS)
SET PSOPRPAS=$PIECE(PSOPAR,"^",13)
PLBL SET PSOION=ION
+1 IF '$DATA(PSOPROP)!($GET(PSOPROP)=ION)
WRITE $CHAR(7),!,"PROFILES MUST BE SENT TO PRINTER !!",!
KILL IOP,%ZIS,IO("Q"),POP
SET %ZIS="MNQ"
SET %ZIS("A")="Select PROFILE DEVICE: "
DO ^%ZIS
KILL %ZIS("A")
IF POP
GOTO QUEUP
IF $EXTRACT(IOST)["C"!(PSOION=ION)
GOTO PLBL
SET PSOPROP=ION
QPRF SET ZTRTN="DQ^PSOPRF"
SET ZTIO=PSOPROP
SET ZTDESC="Outpatient Pharmacy "_$SELECT($GET(SUSPT):"SUSPENSE ",1:"")_"PATIENT PROFILES"
SET ZTDTH=$SELECT($GET(PSOTIME):PSOTIME,1:$HOROLOG)
+1 FOR G="PSOPAR","PSODTCUT","PSOPRPAS","DFN","PSOSITE","NEW1","NEW11","PSOBMST","PFIO","PPL"
IF $DATA(@G)
SET ZTSAVE(G)=""
+2 DO ^%ZTLOAD
IF $DATA(ZTSK)&('$GET(SUSPT))&('$GET(PSOEXREP))
WRITE !,"PROFILE IS QUEUED TO PRINT",!!
KILL G
IF '$GET(SUSPT)
KILL ZTSK
DO ^%ZISC
QUEUP IF $GET(POP)&($GET(PSONOPRT))
Begin DoDot:1
+1 SET PSOQFLAG=1
End DoDot:1
IF $GET(PSOQFLAG)
QUIT
SET PSNP=0
SET PSOPRPAS=$GET(HOLDRPAS)
IF PSOPRPAS']""
KILL PSOPRPAS
KILL HOLDRPAS
GOTO D1
+2 QUIT
+3 ;
S GOTO S^PSORXL1
SUS SET X="IBACUS"
XECUTE ^%ZOSF("TEST")
KILL X
IF '$TEST
GOTO SUSL1
+1 NEW TRIDA
SET TRIDA=DA
IF '$$TRI^IBACUS()
SET DA=TRIDA
GOTO SUSL1
+2 IF $GET(RXRP(TRIDA))!($GET(RXPR(TRIDA)))!($GET(RXRH(TRIDA)))
SET DA=TRIDA
GOTO SUSL1
+3 NEW PBILL,PSTRD,PSTRDZ,PSTRF,PSTRP,GGG
+4 DO DEV^PSOCPTRI
+5 IF '$GET(DT)
SET DT=$$DT^XLFDT
+6 SET PSTRP=$PIECE($GET(^PSRX(+TRIDA,0)),"^",2)
SET PSTRD=+$GET(PSOSITE)
SET PSTRDZ=+$GET(DUZ)
+7 SET PSTRF=0
FOR GGG=0:0
SET GGG=$ORDER(^PSRX(+TRIDA,1,GGG))
IF 'GGG
QUIT
SET PSTRF=GGG
+8 SET PBILL=$$CHPUS^IBACUS(PSTRP,DT,TRIDA,PSTRF,PSOLAP,PSTRD,PSTRDZ)
+9 IF '$GET(PBILL)
SET DA=TRIDA
GOTO SUSL1
+10 SET FLD(99)="99"
SET FLD(99.1)="Awaiting CHAMPUS billing approval"
+11 NEW RSDT,ACT,PSUS,RXF,RFN,I,PSDA,NOW,IR,FDA
+12 SET DA=TRIDA
DO H^PSOCPTRH
+13 QUIT
SUSL1 GOTO SUS^PSORXL1
H1 SET PPL1=1
IF '$GET(PPL)
SET PPL=$GET(PSORX("PSOL",PPL1))
+1 IF '$DATA(^TMP($JOB,"PSOBILL"))
DO NOOR^PSOHLD
IF $DATA(DIRUT)
KILL DIRUT
GOTO PSORXL
+2 IF $DATA(^TMP($JOB,"PSOBILL"))
SET FLD(99)="99"
SET FLD(99.1)="Awaiting CHAMPUS billing approval"
GOTO H
+3 IF $GET(PPL)']""
GOTO D1
DO FLD^PSOHLD
IF $DATA(DUOUT)!($DATA(DIRUT))
KILL DIRUT,DUOUT,FLD,DIR
GOTO LBL
H KILL SPPL
IF $DATA(DTOUT)
GOTO D1
SET SPPL=""
FOR PI=1:1
IF $PIECE(PPL,",",PI)=""
QUIT
Begin DoDot:1
+1 SET DA=$PIECE(PPL,",",PI)
IF $PIECE(^PSRX(DA,"STA"),"^")<10
IF $PIECE(^("STA"),"^")'=4
DO @$SELECT($DATA(^TMP($JOB,"PSOBILL")):"H^PSOCPTRH",1:"H^PSOHLD")
QUIT
+2 IF $PIECE(^PSRX(DA,"STA"),"^")=4
SET SPPL=SPPL_DA_","
QUIT
End DoDot:1
+3 IF $GET(SPPL)]""
Begin DoDot:1
+4 WRITE !!,$CHAR(7),"Drug Interaction Rx(s) "
FOR I=1:1
IF $PIECE(SPPL,",",I)=""
QUIT
WRITE $PIECE(^PSRX($PIECE(SPPL,",",I),0),"^")_", "
+5 SET PPL=SPPL
SET DG=1
DO Q
KILL DG,SPPL
End DoDot:1
D1 KILL RXLTOP
IF $GET(PPL1)
IF $ORDER(PSORX("PSOL",$GET(PPL1)))
SET PPL1=$ORDER(PSORX("PSOL",PPL1))
SET PPL=PSORX("PSOL",PPL1)
GOTO @$SELECT(LBL="H":"H",LBL="L":"P1",1:"QLBL")
RXS IF $DATA(RXRS)
IF '$GET(PSOKLRXS)
IF $GET(SLBL)="H"!($GET(SLBL)="S")!($GET(SLBL)="^")!($GET(SLBL)="")
Begin DoDot:1
+1 KILL PPL,PSORX("PSOL")
SET PSOSONE=1
DO PPLADD^PSOSUPOE
+2 IF $GET(PPL)=""
QUIT
WRITE !!,"You have selected the following Rx(s) to be pulled from suspense:",!
+3 FOR RXSS=0:0
SET RXSS=$ORDER(RXRS(RXSS))
IF 'RXSS
QUIT
WRITE !," Rx # ",$PIECE($GET(^PSRX(+$GET(RXSS),0)),"^"),?23,$PIECE($GET(^PSDRUG(+$PIECE($GET(^PSRX(+$GET(RXSS),0)),"^",6),0)),"^")
+4 KILL DIR
WRITE !
SET DIR(0)="Y"
SET DIR("B")="YES"
SET DIR("A")="Do you still want to pull these Rx(s) from suspense"
DO ^DIR
KILL DIR
IF Y'=1
WRITE !!,"Rx(s) will remain in Suspense!",!
DO RESET^PSOSUPOE
KILL RXRS,PPL
End DoDot:1
IF $GET(PPL)'=""
GOTO Q
+5 IF '$GET(PSOKLRXS)
KILL RXRS
KILL ^TMP($JOB,"PSOBILL"),RXPR,RXRP,RXRH,RXSS,LBL,PPL1,PPL,DIR,%DT,%,SD,COUNT,EXDT,L,PDUZ,REF,REPRINT,RFDATE,RFL1,RFLL,RXN,WARN,ZY,FLD,PI,ZD,ACT,X,Y,DIRUT,DUOUT,DTOUT,DIROUT
QUIT
P SET PPL1=1
IF '$GET(PPL)
SET PPL=$GET(PSORX("PSOL",1))
IF $GET(PPL)']""
GOTO D1
+1 IF $GET(PSOLAP)']""
WRITE !
KILL POP,ZTSK
SET %ZIS="M"
SET %ZIS("A")="Select LABEL DEVICE: "
DO ^%ZIS
KILL %ZIS("A")
IF POP
GOTO LBL
SET PSOLAP=ION
PZ ; IHS/CIA/PLS - 12/23/03 - PZ line label added
SET IOP=PSOLAP
DO ^%ZIS
+1 ; IHS/CIA/PLS - 12/23/03 Wait for busy printer prompt.
IF POP
WRITE !,"The label printer is busy, do you want to wait? "
SET %=1
DO YN^DICN
KILL POP
IF %=2
QUIT
KILL %,%Y
GOTO PZ
+2 NEW PSOIOS
SET PSOIOS=IOS
DO DEVBAR^PSOBMST
P1 ; IHS/CIA/PLS - 12/23/03 - Call IHS Label routine
+1 ;S PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$P(PSOPAR,"^",10),PDUZ=DUZ D DQ1^PSOLBL,^%ZISC
+2 SET PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$PIECE(PSOPAR,"^",10)
SET PDUZ=DUZ
DO DQ1^APSPLBL
DO ^%ZISC
+3 IF '$PIECE(PSOPAR,"^",8)!(+$GET(REPRINT))!($GET(PSOFROM)'="NEW")
GOTO D1
IF $GET(PSOPROP)']""
SET PSOION=ION
SET %ZIS="M"
SET %ZIS("A")="Select PROFILE DEVICE: "
DO ^%ZIS
KILL %ZIS("A")
IF POP
GOTO D1
SET PSOPROP=ION
+4 SET IOP=PSOPROP
DO ^%ZIS
DO DQ^PSOPRF
DO ^%ZISC
GOTO D1
+5 QUIT
RXSQ KILL RXRS
GOTO RXS
+1 QUIT
RSAVE NEW PMX
+1 SET PMX=""
FOR
SET PMX=$ORDER(RXRP(PMX))
IF PMX=""
QUIT
SET PSORSAVE(PMX)=RXRP(PMX)
+2 SET PMX=""
FOR
SET PMX=$ORDER(RXPR(PMX))
IF PMX=""
QUIT
SET PSOPSAVE(PMX)=RXPR(PMX)
+3 SET PMX=""
FOR
SET PMX=$ORDER(RXRH(PMX))
IF PMX=""
QUIT
SET PSOHSAVE(PMX)=RXRH(PMX)
+4 QUIT
RREST NEW PMXZ
+1 SET PMXZ=""
FOR
SET PMXZ=$ORDER(PSORSAVE(PMXZ))
IF PMXZ=""
QUIT
SET RXRP(PMXZ)=PSORSAVE(PMXZ)
+2 SET PMXZ=""
FOR
SET PMXZ=$ORDER(PSOPSAVE(PMXZ))
IF PMXZ=""
QUIT
SET RXPR(PMXZ)=PSOPSAVE(PMXZ)
+3 SET PSMX=""
FOR
SET PMXZ=$ORDER(PSOHSAVE(PMXZ))
IF PMXZ=""
QUIT
SET RXRH(PMXZ)=PSOHSAVE(PMXZ)
+4 QUIT
+5 ; Store Fill Priority
SAVEPRI(RXS) ;EP-
+1 NEW PPLARY,RX,LFN
+2 IF '$LENGTH($GET(RXS))
QUIT
+3 DO BPPLARY^APSPFUNC(RXS)
+4 SET RX=0
+5 FOR
SET RX=$ORDER(PPLARY(RX))
IF 'RX
QUIT
Begin DoDot:1
+6 IF '$DATA(^PSRX(RX,0))
QUIT
+7 SET LFN=+$ORDER(^(1,$CHAR(1)),-1)
+8 ;Refill
IF LFN
Begin DoDot:2
+9 SET $PIECE(^PSRX(RX,1,LFN,9999999),U,18)=APSPPRIO
End DoDot:2
+10 ;
IF '$TEST
Begin DoDot:2
+11 SET $PIECE(^PSRX(RX,999999931),U,8)=APSPPRIO
End DoDot:2
End DoDot:1
+12 QUIT
