PSOLBL ;BIR/SAB/RTR - BOTTLE LABEL ;08/23/17 20:03
;;7.0;OUTPATIENT PHARMACY;**8,19,30,36,47,71,92,120,157,244,206,225,303,266,326,251,387,379,367,441,753**;DEC 1997;Build 53
;DBIAs PSDRUG-221, PS(55-2228, IBARX-125, PSXSRP-2201, %ZIS-3435, DPT-3097
;External reference to $$DS^PSSDSAPI supported by DBIA 5425
;External reference to ^DIC(5 supported by DBIA 4293
;External reference to ^SC( supported by DBIA 2675
;External reference to XTYPE^IBARX supported by DBIA 125
;External reference to %ZIS(2 supported by DBIA 812
;
;*244 rem test for part fill when testing status > 11
;
DQ I $D(PSOIOS),PSOIOS]"" D DEVBAR^PSOBMST
I $G(PSOBAR0)]"",$G(PSOBAR1)]"",$D(^PS(59,PSOSITE,1)) S PSOBARS=1
DQ1 D ^PSOLBL4
I $G(IOST(0)),$D(^%ZIS(2,IOST(0),55,"B","LL")) G ^PSOLLLI
G:'$D(PPL) HLEX G:($P($G(PSOPAR),"^",30)=2)&('$G(PSOEXREP)) HLEX K RXFLX S PSOCKHN=","_$G(PPL) S PSRESOLV=+PPL D CHECK F PI=1:1 D S RX=$P(PPL,",",PI) D C Q:$G(PSOLAPPL) D:$G(PSDFNFLG) TRAIL^PSOLBL2 K RXP,REPRINT
.S (PSDFNFLG,PSOLAPPL)=0 S NEXTRX=$P(PPL,",",(PI+1)) I NEXTRX=""!(NEXTRX=",") S PSOLAPPL=1 Q
.I PSOPDFN'=$P(^PSRX(NEXTRX,0),"^",2) S PSDFNFLG=1,PSOPDFN=$P(^PSRX(NEXTRX,0),"^",2) Q
I $P(^PS(59,PSOSITE,1),"^",28) D ^PSOLBLN2
D:'$P(^PS(59,PSOSITE,1),"^",28) ^PSOLBLS
DQ5 I $D(^TMP($J,"PSOCP",DFN)),'$P(^PS(59,PSOSITE,1),"^",28) D INV^PSOCPE
HLEX K RXPI,PSORX,RXP,PSOIOS,PSOLAPPL,XXX,COPAYVAR,TECH,PHYS,MFG,NURSE,STATE,SIDE,COPIES,EXDT,ISD,PSOINST,RXN,RXY,VADT,DEA,WARN,FDT,QTY,PATST,PDA,PS,PS1,PS2,PSL,PSNP,INRX,RR,XTYPE,SSNP,SSNPN,PNM
K ADDR,PSODBQ,PSOLASTF,PSRESOLV,PSOEXREP,PSOSXQ,A,LINE,DAYS,DATE,DRUG,EXPDT,II,LOT,MW,PI,PRTFL,PS55,PS55X,PSCAP,PSCLN,PSI,PSMP,PSOBARS,PSOBLRX,RXF,RXSTA,SIG,VRPH,PSOSCOPI
K ^TMP($J,"PSOCP",+$G(PSOCPN)),REF,PSOCPN,PSOLBLDR,PSOLBLPS,PSOLBLCP,RXPR,RXRP,RXRS,PSOCKHN,RXFLX,PSOLAPPL,PSOPDFN,PSDFNFLG,PSOZERO,NEXTRX,PSOBLALL,STA S:'$G(PSOSUREP)&('$G(PSOSUSPR)) ZTREQ="@" Q
C I $G(IOST(0)),$D(^%ZIS(2,IOST(0),55,"B","LL")) G C^PSOLLLI
U IO S X=$S('$P(^PS(59,PSOSITE,1),"^",28):132,1:158) X ^%ZOSF("RM") Q:'$D(^PSRX(RX,0))
S:$G(PSOBLALL) PSOBLRX=RX K LINE
S:$D(RXRP(RX)) REPRINT=1 S:$D(RXPR(RX)) RXP=RXPR(RX)
I $G(PSOSUREP)!($G(PSOEXREP)) S REPRINT=1 S:'$G(RXRP(RX)) RXRP(RX)=1 S:$G(PSOMGREP) RXRP(RX,"MG")=1
S RXY=^PSRX(RX,0),RXSTA=$P(^PSRX(RX,"STA"),"^") I RXSTA>11 D AL("QT") K RXY,RXP,REPRINT Q ;*244
I RXSTA=3 D AL("QT") K RXY,RXP,REPRINT Q
I $G(RXPR(RX)),'$D(^PSRX(RX,"P",RXP,0)) K RXY,RXP,REPRINT Q
I $P($G(RXFL(RX)),"^"),'$D(^PSRX(RX,1,$P($G(RXFL(RX)),"^"),0)) K RXY,RXP,REPRINT Q
I $G(PSODBQ)!($G(RXRS(RX))) S RR=$O(^PS(52.5,"B",RX,0)) Q:'RR I $G(^PS(52.5,RR,"P"))=1 K RXY,RXP,REPRINT Q
I $G(RXRS(RX))!($G(PSOPULL)) S PSOSXQ=0 N DR,DA,DIE D I $G(PSOSXQ) K RXY,RXP,REPRINT Q
.S DA=$O(^PS(52.5,"B",RX,0)) Q:'DA S A=$P($G(^PS(52.5,DA,0)),"^",7) Q:A=""
.I A="Q" S DIE="^PS(52.5,",DR="3////P" D ^DIE Q
.K RXRS(RX) S PSOSXQ=1
I $G(PSRESOLV)=RX D ENLBL^PSOBSET K PSRESOLV
I RXSTA'=4 D:$G(PSOSUSPR) AREC^PSOSUTL D:$G(PSOPULL)!($G(RXRS(RX))) AREC1^PSOSUTL D:$G(PSOSUREP) AREC^PSOSUSRP D:$G(PSXREP) AREC^PSXSRP
K ^UTILITY("DIQ1",$J) S DA=$P($$SITE^VASITE(),"^") I $G(DA) S DIC=4,DIQ(0)="I",DR="99" D EN^DIQ1 S PSOINST=$G(^UTILITY("DIQ1",$J,4,DA,99,"I")) K ^UTILITY("DIQ1",$J),DA,DR,DIC
S RXN=$P(RXY,"^"),ISD=$P(RXY,"^",13),RXF=0,DFN=+$P(RXY,"^",2),SIG=$P($G(^PSRX(RX,"SIG")),"^"),ISD=$E(ISD,4,5)_"/"_$E(ISD,6,7)_"/"_($E(ISD,1,3)+1700),ZY=0,$P(LINE,"_",28)="_"
S PSOLBLPS=+$P(RXY,"^",3),PSOLBLDR=+$P(RXY,"^",6)
S NURSE=$S($P($G(^DPT(DFN,"NHC")),"^")="Y":1,$P($G(^PS(55,DFN,40)),"^"):1,1:0) S FDT=$P(^PSRX(RX,2),"^",2),PS=$S($D(^PS(59,PSOSITE,0)):^(0),1:""),PS1=$S($D(^(1)):^(1),1:""),PSOSITE7=$P(^("IB"),"^")
S PS2=$P(PS,"^")_"^"_$P(PS,"^",6)
S (EXPDT,EXDT)=$P(^PSRX(RX,2),"^",6),EXDT=$S('EXDT:"",1:$E(EXDT,4,5)_"/"_$E(EXDT,6,7)_"/"_($E(EXDT,1,3)+1700))
S COPIES=$S($P($G(RXRP(RX)),"^",2):$P($G(RXRP(RX)),"^",2),$P(RXY,"^",18)]"":$P(RXY,"^",18),1:1)
K PSOCKHNX S PSOCKHL=$L(RX),PSOCKHN=$E($G(PSOCKHN),(PSOCKHL+2),999) D K PSOCKHNX,PSOCKHL,PSOCKHA
.S PSOCKHA=","_RX_","
.I PSOCKHN'[PSOCKHA Q
.S PSOCKHA=$E(PSOCKHA,1,($L(PSOCKHA)-1))
.S PSOCKHNX=$L(PSOCKHN,PSOCKHA)-1
.I +$G(PSOCKHNX)>0 D DOUB
I $O(^PSRX(RX,1,0)),$G(RXFL(RX))'=0 S $P(^PSRX(RX,3),"^",6)="" K ^PSRX(RX,"DAI"),^PSRX(RX,"DRI")
I '$G(RXP),'$O(^PSRX(RX,1,0)) S RXFL(RX)=0
I '$G(RXP) D OSET I '$O(^PSRX(RX,1,0))!($G(RXFL(RX))=0) G ORIG
I $O(^PSRX(RX,1,0)),'$G(RXP),'$G(RXFL(RX)) S XTYPE=1 D REF G STA
I $O(^PSRX(RX,1,0)),'$G(RXP),$G(RXFL(RX)) G STA
I $G(RXP) S XTYPE="P" D REF G STA
ORIG S TECH=$P($G(^VA(200,+$P(^PSRX(RX,0),"^",16),0)),"^"),QTY=$P(^PSRX(RX,0),"^",7),PHYS=$S($D(^VA(200,+$P(^PSRX(RX,0),"^",4),0)):$P(^(0),"^"),1:"UKN") D 6^VADPT,PID^VADPT S SSNPN=""
S DAYS=$P(^PSRX(RX,0),"^",8),MFG="________",LOT="________"
STA S STATE=$S($D(^DIC(5,+$P(PS,"^",8),0)):$P(^(0),"^",2),1:"UKN")
S DRUG=$$ZZ^PSOSUTL(RX),DEA=$P($G(^PSDRUG(+$P(RXY,"^",6),0)),"^",3),WARN=$P($G(^(0)),"^",8)
S SIDE=$S($P($G(RXRP(RX)),"^",3):1,1:0)
I $G(^PSRX(RX,"P",+$G(RXP),0))]"" S RXPI=RXP D
.S RXP=^PSRX(RX,"P",RXP,0)
.S RXY=$P(RXP,"^")_"^"_$P(RXY,"^",2,6)_"^"_$P(RXP,"^",4)_"^"_$P(RXP,"^",10)_"^"_$P(RXY,"^",9)_"^"_$P($G(^PSRX(RX,"SIG")),"^",2)_"^"_$P(RXP,"^",2)_"^"_$P(RXY,"^",12,14)_"^"_$P(^PSRX(RX,"STA"),"^")_"^"_$P(RXP,"^",7)_"^"_$P(RXY,"^",17,99)
.S FDT=$P(RXP,"^")
S MW=$P(RXY,"^",11) I $G(RXFL(RX))'=0 D:$G(RXFL(RX)) I '$G(RXFL(RX)) F I=0:0 S I=$O(^PSRX(RX,1,I)) Q:'I S RXF=RXF+1 S:'$G(RXP) MW=$P(^PSRX(RX,1,I,0),"^",2) I +^PSRX(RX,1,I,0)'<FDT S FDT=+^(0)
.I $G(RXFL(RX)),'$D(^PSRX(RX,1,RXFL(RX),0)) K RXFL(RX) Q
.;PSO*7*266
.S RXF=RXFL(RX) S:'$G(RXP) MW=$P($G(^PSRX(RX,1,RXF,0)),"^",2) F I=0:0 S I=$O(^PSRX(RX,1,I)) Q:'I I +^PSRX(RX,1,I,0)'<FDT S FDT=+^(0)
I MW="W" S PSMP=$G(^PSRX(RX,"MP")) I PSMP]"" D
.N PSJ S PSJ=0 F PSI=1:1:$L(PSMP) S PSMP(PSI)="",PSJ=PSJ+1 F PSJ=PSJ:1 S PSMP(PSI)=PSMP(PSI)_$P(PSMP," ",PSJ)_" " Q:($L(PSMP(PSI))+$L($P(PSMP," ",PSJ+1))>30)
.K PSMP(PSI)
S X=$S($D(^PS(55,DFN,0)):^(0),1:""),PSCAP=$P(X,"^",2),PS55=$P($G(X),"^",3),PS55X=$P($G(X),"^",5)
I (($G(PS55X)]"")&(PS55>1)&(PS55X<DT)) S PS55=0
I $$GET1^DIQ(52,RX,100.2,"I")]"" S PS55=$$GET1^DIQ(52,RX,100.2,"I"),PS55X="" ;p753
S:MW="M" MW=$S((PS55=1!(PS55=4)):"R",1:MW)
;S MW=$S(MW="M":"REGULAR",MW="R":"CERTIFIED",1:"WINDOW") ;COMMENTED OUT V32 LINE OF CODE IN FAVOUR OF FOLLOWING PAPI LINE OF CODE
S MW=$S(MW="M":"REGULAR",MW="R":"CERTIFIED",MW="P":"PARK",1:"WINDOW")
I ($G(PSMP(1))']""&($G(PS55)=2)) S PSMP(1)=$G(SSNPN)
S DATE=$E(FDT,1,7),REF=$P(RXY,"^",9)-RXF S:'$G(RXP) $P(^PSRX(RX,3),"^")=FDT S:REF<1 REF=0 D ^PSOLBL2 S II=RX D ^PSORFL,RFLDT^PSORFL
S PATST=$G(^PS(53,+$P(RXY,"^",3),0)) S PRTFL=1 I REF=0 S:('$P(PATST,"^",5))!(DEA["W")!(DEA[1)!(DEA[2) PRTFL=0
S VRPH=$P(^PSRX(RX,2),"^",10),PSCLN=+$P(RXY,"^",5),PSCLN=$S($D(^SC(PSCLN,0)):$P(^(0),"^",2),1:"UNKNOWN")
S PATST=$P(PATST,"^",2),X1=DT,X2=$P(RXY,"^",8)-10 D C^%DTC:REF I $D(^PSRX(RX,2)),$P(^(2),"^",6),REF,X'<$P(^(2),"^",6) S REF=0,VRPH=$P(^(2),"^",10)
I $G(PSOCHAMP),$G(PSOTRAMT) S COPAYVAR="CHAMPUS" G LBL
I $G(RXP) S COPAYVAR="" G LBL
I $P($G(^PS(53,+$G(PSOLBLPS),0)),"^",7) D SNO G LBL
I $P($G(^PSDRUG(+$G(PSOLBLDR),0)),"^",3)["I"!($P($G(^(0)),"^",3)["S")!($P($G(^(0)),"^",3)["N") D SNO G LBL
I $P(^PSRX(RX,"STA"),"^")>0,$P(^("STA"),"^")'=2,'$G(PSODBQ) D SNO G LBL
I $G(PSOLBLCP)="" D IBCP
N PSOQI S PSOQI=$G(^PSRX(RX,"IBQ")) I $G(PSOLBLCP)=0 D SNO G LBL
I $G(PSOLBLCP)=1 I $P(PSOQI,"^",2)!($P(PSOQI,"^",3))!($P(PSOQI,"^",4))!($P(PSOQI,"^",5))!($P(PSOQI,"^",6))!($P(PSOQI,"^",7))!($P(PSOQI,"^",8)) D SNO G LBL
I $G(PSOLBLCP)=2 I $P(PSOQI,"^")!($P(PSOQI,"^",2))!($P(PSOQI,"^",3))!($P(PSOQI,"^",4))!($P(PSOQI,"^",5))!($P(PSOQI,"^",6))!($P(PSOQI,"^",7))!($P(PSOQI,"^",8)) D SNO G LBL
I $G(PSOLBLCP)=2,'$P($G(^PSRX(RX,"IB")),"^") D SNO G LBL
S PSOCPN=$P(^PSRX(RX,0),"^",2),INRX=$P(^(0),"^") I $G(^TMP($J,"PSOCP",PSOCPN))="" S ^(PSOCPN)=PSOCPN
S ^TMP($J,"PSOCP",PSOCPN,INRX)=INRX_"^"_$$ZZ^PSOSUTL(RX)_"^"_+$G(DAYS) S COPAYVAR="COPAY" K ZDRUG
LBL ;
S PSOSCOPI=$G(COPIES)
G ^PSOLBLD:$P(^PSRX(RX,"STA"),"^")=4!($$DS^PSSDSAPI&'$G(RXF)&'$G(RXP)&$G(^PS(52.4,RX,1))) ;critical drug interaction status or dose warning and not a refill or partial - print warning label
D ^PSOLBLD:$D(^PSRX(RX,"DRI"))&('$G(RXF))&('$G(RXP)) S COPIES=PSOSCOPI ;print warning label for critical and significant interactions
D:$P($G(^PSRX(RX,3)),"^",6)&('$G(RXF))&('$G(RXP)) ^PSOLBLD1
G ^PSOLBL1:'$P(^PS(59,PSOSITE,1),"^",28)
I $$DS^PSSDSAPI,'$G(RXF),'$G(RXP) Q:$D(^PS(52.4,RX,1)) ;already printed warning label above, quit if dose warning and don't print bottle label
Q:(($P(^PSRX(RX,"STA"),"^")=4!($P($G(^PSRX(RX,"DRI")),"^",1)[1))&('$G(RXF))&('$G(RXP))) ;if signficant warning (DRI node piece 1 contains only 2's) continue to print bottle label
S COPIES=PSOSCOPI S:'$G(COPIES) COPIES=1 G ^PSOLBLN
REF F XXX=0:0 S XXX=$O(^PSRX(RX,XTYPE,XXX)) Q:+XXX'>0 D
.S TECH=$S($D(^VA(200,+$P(^PSRX(RX,XTYPE,XXX,0),"^",7),0)):$P(^(0),"^"),1:"UNKNOWN")
.S QTY=$P(^PSRX(RX,XTYPE,XXX,0),"^",4),PHYS=$S($D(^VA(200,+$P(^PSRX(RX,XTYPE,XXX,0),"^",17),0)):$P(^(0),"^"),$D(^VA(200,+$P(^PSRX(RX,0),"^",4),0)):$P(^(0),"^"),1:"UNKNOWN") D 6^VADPT,PID^VADPT S SSNPN=""
.S DAYS=$P(^PSRX(RX,XTYPE,XXX,0),"^",10),LOT="________",MFG="________"
Q
CHECK S PSDFNFLG=0,PSOZERO=$P(PPL,","),PSOPDFN=$P(^PSRX(PSOZERO,0),"^",2)
Q
OSET D OSET^PSOLBL1
Q
DOUB Q:'$D(RXFL(RX)) I +$G(RXFL(RX))-PSOCKHNX<0 Q
S RXFLX(RX)=$G(RXFL(RX)),RXFL(RX)=$G(RXFL(RX))-PSOCKHNX
Q
AL(T) N I,IR,RF,USR,TY,DES S USR=""
I T="UT" D
.N J,RX S USR=$G(DUZ),TY="B",DES="Label never queued to print by User"
.F J=1:1 S RX=+$P(PPL,",",J) Q:'RX D AL1
I T="QT" D
.S I=+$P(^PSRX(RX,"STA"),"^"),TY=$S((I=3)!(I=16):"H",I=13:"D",1:"C")
.S DES=I_" "_$S((I=3)!(I=16):"HOLD"_$S(I=16:"(PROVIDER)",1:""),(I=12)!(I=14)!(I=15):"DISCONTINUED"_$S(I=14:"(PROVIDER)",I=15:"(EDIT)",1:""),I=13:"DELETED",1:"")
.S DES="Queued label terminated - "_DES D AL1
K %,%H,%I Q
AL1 S (IR,I,RF)=0 F S I=$O(^PSRX(RX,1,I)) Q:'I S RF=I S:I>5 RF=I+1
S I=0 F S I=$O(^PSRX(RX,"A",I)) Q:'I S IR=I
S IR=IR+1,^PSRX(RX,"A",0)="^52.3DA^"_IR_"^"_IR
D NOW^%DTC S ^PSRX(RX,"A",IR,0)=%_"^"_TY_"^"_USR_"^"_$S($G(RXPR(RX)):6,1:RF)_"^"_DES
Q
IBCP N X,Y,PSOJJ,PSOLL
S PSOLBLCP="",X=$P($G(^PS(59,+$G(PSOSITE),"IB")),"^")_"^"_$G(DFN) D XTYPE^IBARX
S PSOJJ="" F S PSOJJ=$O(Y(PSOJJ)) Q:'PSOJJ S PSOLL="" F S PSOLL=$O(Y(PSOJJ,PSOLL)) Q:PSOLL="" S:PSOLL>0 PSOLBLCP=PSOLL
I '$G(PSOLBLCP) S PSOLBLCP=0
Q
SNO S COPAYVAR="NO COPAY" Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOLBL 10560 printed Oct 16, 2024@18:30:58 Page 2
PSOLBL ;BIR/SAB/RTR - BOTTLE LABEL ;08/23/17 20:03
+1 ;;7.0;OUTPATIENT PHARMACY;**8,19,30,36,47,71,92,120,157,244,206,225,303,266,326,251,387,379,367,441,753**;DEC 1997;Build 53
+2 ;DBIAs PSDRUG-221, PS(55-2228, IBARX-125, PSXSRP-2201, %ZIS-3435, DPT-3097
+3 ;External reference to $$DS^PSSDSAPI supported by DBIA 5425
+4 ;External reference to ^DIC(5 supported by DBIA 4293
+5 ;External reference to ^SC( supported by DBIA 2675
+6 ;External reference to XTYPE^IBARX supported by DBIA 125
+7 ;External reference to %ZIS(2 supported by DBIA 812
+8 ;
+9 ;*244 rem test for part fill when testing status > 11
+10 ;
DQ IF $DATA(PSOIOS)
IF PSOIOS]""
DO DEVBAR^PSOBMST
+1 IF $GET(PSOBAR0)]""
IF $GET(PSOBAR1)]""
IF $DATA(^PS(59,PSOSITE,1))
SET PSOBARS=1
DQ1 DO ^PSOLBL4
+1 IF $GET(IOST(0))
IF $DATA(^%ZIS(2,IOST(0),55,"B","LL"))
GOTO ^PSOLLLI
+2 if '$DATA(PPL)
GOTO HLEX
if ($PIECE($GET(PSOPAR),"^",30)=2)&('$GET(PSOEXREP))
GOTO HLEX
KILL RXFLX
SET PSOCKHN=","_$GET(PPL)
SET PSRESOLV=+PPL
DO CHECK
FOR PI=1:1
Begin DoDot:1
+3 SET (PSDFNFLG,PSOLAPPL)=0
SET NEXTRX=$PIECE(PPL,",",(PI+1))
IF NEXTRX=""!(NEXTRX=",")
SET PSOLAPPL=1
QUIT
+4 IF PSOPDFN'=$PIECE(^PSRX(NEXTRX,0),"^",2)
SET PSDFNFLG=1
SET PSOPDFN=$PIECE(^PSRX(NEXTRX,0),"^",2)
QUIT
End DoDot:1
SET RX=$PIECE(PPL,",",PI)
DO C
if $GET(PSOLAPPL)
QUIT
if $GET(PSDFNFLG)
DO TRAIL^PSOLBL2
KILL RXP,REPRINT
+5 IF $PIECE(^PS(59,PSOSITE,1),"^",28)
DO ^PSOLBLN2
+6 if '$PIECE(^PS(59,PSOSITE,1),"^",28)
DO ^PSOLBLS
DQ5 IF $DATA(^TMP($JOB,"PSOCP",DFN))
IF '$PIECE(^PS(59,PSOSITE,1),"^",28)
DO INV^PSOCPE
HLEX KILL RXPI,PSORX,RXP,PSOIOS,PSOLAPPL,XXX,COPAYVAR,TECH,PHYS,MFG,NURSE,STATE,SIDE,COPIES,EXDT,ISD,PSOINST,RXN,RXY,VADT,DEA,WARN,FDT,QTY,PATST,PDA,PS,PS1,PS2,PSL,PSNP,INRX,RR,XTYPE,SSNP,SSNPN,PNM
+1 KILL ADDR,PSODBQ,PSOLASTF,PSRESOLV,PSOEXREP,PSOSXQ,A,LINE,DAYS,DATE,DRUG,EXPDT,II,LOT,MW,PI,PRTFL,PS55,PS55X,PSCAP,PSCLN,PSI,PSMP,PSOBARS,PSOBLRX,RXF,RXSTA,SIG,VRPH,PSOSCOPI
+2 KILL ^TMP($JOB,"PSOCP",+$GET(PSOCPN)),REF,PSOCPN,PSOLBLDR,PSOLBLPS,PSOLBLCP,RXPR,RXRP,RXRS,PSOCKHN,RXFLX,PSOLAPPL,PSOPDFN,PSDFNFLG,PSOZERO,NEXTRX,PSOBLALL,STA
if '$GET(PSOSUREP)&('$GET(PSOSUSPR))
SET ZTREQ="@"
QUIT
C IF $GET(IOST(0))
IF $DATA(^%ZIS(2,IOST(0),55,"B","LL"))
GOTO C^PSOLLLI
+1 USE IO
SET X=$SELECT('$PIECE(^PS(59,PSOSITE,1),"^",28):132,1:158)
XECUTE ^%ZOSF("RM")
if '$DATA(^PSRX(RX,0))
QUIT
+2 if $GET(PSOBLALL)
SET PSOBLRX=RX
KILL LINE
+3 if $DATA(RXRP(RX))
SET REPRINT=1
if $DATA(RXPR(RX))
SET RXP=RXPR(RX)
+4 IF $GET(PSOSUREP)!($GET(PSOEXREP))
SET REPRINT=1
if '$GET(RXRP(RX))
SET RXRP(RX)=1
if $GET(PSOMGREP)
SET RXRP(RX,"MG")=1
+5 ;*244
SET RXY=^PSRX(RX,0)
SET RXSTA=$PIECE(^PSRX(RX,"STA"),"^")
IF RXSTA>11
DO AL("QT")
KILL RXY,RXP,REPRINT
QUIT
+6 IF RXSTA=3
DO AL("QT")
KILL RXY,RXP,REPRINT
QUIT
+7 IF $GET(RXPR(RX))
IF '$DATA(^PSRX(RX,"P",RXP,0))
KILL RXY,RXP,REPRINT
QUIT
+8 IF $PIECE($GET(RXFL(RX)),"^")
IF '$DATA(^PSRX(RX,1,$PIECE($GET(RXFL(RX)),"^"),0))
KILL RXY,RXP,REPRINT
QUIT
+9 IF $GET(PSODBQ)!($GET(RXRS(RX)))
SET RR=$ORDER(^PS(52.5,"B",RX,0))
if 'RR
QUIT
IF $GET(^PS(52.5,RR,"P"))=1
KILL RXY,RXP,REPRINT
QUIT
+10 IF $GET(RXRS(RX))!($GET(PSOPULL))
SET PSOSXQ=0
NEW DR,DA,DIE
Begin DoDot:1
+11 SET DA=$ORDER(^PS(52.5,"B",RX,0))
if 'DA
QUIT
SET A=$PIECE($GET(^PS(52.5,DA,0)),"^",7)
if A=""
QUIT
+12 IF A="Q"
SET DIE="^PS(52.5,"
SET DR="3////P"
DO ^DIE
QUIT
+13 KILL RXRS(RX)
SET PSOSXQ=1
End DoDot:1
IF $GET(PSOSXQ)
KILL RXY,RXP,REPRINT
QUIT
+14 IF $GET(PSRESOLV)=RX
DO ENLBL^PSOBSET
KILL PSRESOLV
+15 IF RXSTA'=4
if $GET(PSOSUSPR)
DO AREC^PSOSUTL
if $GET(PSOPULL)!($GET(RXRS(RX)))
DO AREC1^PSOSUTL
if $GET(PSOSUREP)
DO AREC^PSOSUSRP
if $GET(PSXREP)
DO AREC^PSXSRP
+16 KILL ^UTILITY("DIQ1",$JOB)
SET DA=$PIECE($$SITE^VASITE(),"^")
IF $GET(DA)
SET DIC=4
SET DIQ(0)="I"
SET DR="99"
DO EN^DIQ1
SET PSOINST=$GET(^UTILITY("DIQ1",$JOB,4,DA,99,"I"))
KILL ^UTILITY("DIQ1",$JOB),DA,DR,DIC
+17 SET RXN=$PIECE(RXY,"^")
SET ISD=$PIECE(RXY,"^",13)
SET RXF=0
SET DFN=+$PIECE(RXY,"^",2)
SET SIG=$PIECE($GET(^PSRX(RX,"SIG")),"^")
SET ISD=$EXTRACT(ISD,4,5)_"/"_$EXTRACT(ISD,6,7)_"/"_($EXTRACT(ISD,1,3)+1700)
SET ZY=0
SET $PIECE(LINE,"_",28)="_"
+18 SET PSOLBLPS=+$PIECE(RXY,"^",3)
SET PSOLBLDR=+$PIECE(RXY,"^",6)
+19 SET NURSE=$SELECT($PIECE($GET(^DPT(DFN,"NHC")),"^")="Y":1,$PIECE($GET(^PS(55,DFN,40)),"^"):1,1:0)
SET FDT=$PIECE(^PSRX(RX,2),"^",2)
SET PS=$SELECT($DATA(^PS(59,PSOSITE,0)):^(0),1:"")
SET PS1=$SELECT($DATA(^(1)):^(1),1:"")
SET PSOSITE7=$PIECE(^("IB"),"^")
+20 SET PS2=$PIECE(PS,"^")_"^"_$PIECE(PS,"^",6)
+21 SET (EXPDT,EXDT)=$PIECE(^PSRX(RX,2),"^",6)
SET EXDT=$SELECT('EXDT:"",1:$EXTRACT(EXDT,4,5)_"/"_$EXTRACT(EXDT,6,7)_"/"_($EXTRACT(EXDT,1,3)+1700))
+22 SET COPIES=$SELECT($PIECE($GET(RXRP(RX)),"^",2):$PIECE($GET(RXRP(RX)),"^",2),$PIECE(RXY,"^",18)]"":$PIECE(RXY,"^",18),1:1)
+23 KILL PSOCKHNX
SET PSOCKHL=$LENGTH(RX)
SET PSOCKHN=$EXTRACT($GET(PSOCKHN),(PSOCKHL+2),999)
Begin DoDot:1
+24 SET PSOCKHA=","_RX_","
+25 IF PSOCKHN'[PSOCKHA
QUIT
+26 SET PSOCKHA=$EXTRACT(PSOCKHA,1,($LENGTH(PSOCKHA)-1))
+27 SET PSOCKHNX=$LENGTH(PSOCKHN,PSOCKHA)-1
+28 IF +$GET(PSOCKHNX)>0
DO DOUB
End DoDot:1
KILL PSOCKHNX,PSOCKHL,PSOCKHA
+29 IF $ORDER(^PSRX(RX,1,0))
IF $GET(RXFL(RX))'=0
SET $PIECE(^PSRX(RX,3),"^",6)=""
KILL ^PSRX(RX,"DAI"),^PSRX(RX,"DRI")
+30 IF '$GET(RXP)
IF '$ORDER(^PSRX(RX,1,0))
SET RXFL(RX)=0
+31 IF '$GET(RXP)
DO OSET
IF '$ORDER(^PSRX(RX,1,0))!($GET(RXFL(RX))=0)
GOTO ORIG
+32 IF $ORDER(^PSRX(RX,1,0))
IF '$GET(RXP)
IF '$GET(RXFL(RX))
SET XTYPE=1
DO REF
GOTO STA
+33 IF $ORDER(^PSRX(RX,1,0))
IF '$GET(RXP)
IF $GET(RXFL(RX))
GOTO STA
+34 IF $GET(RXP)
SET XTYPE="P"
DO REF
GOTO STA
ORIG SET TECH=$PIECE($GET(^VA(200,+$PIECE(^PSRX(RX,0),"^",16),0)),"^")
SET QTY=$PIECE(^PSRX(RX,0),"^",7)
SET PHYS=$SELECT($DATA(^VA(200,+$PIECE(^PSRX(RX,0),"^",4),0)):$PIECE(^(0),"^"),1:"UKN")
DO 6^VADPT
DO PID^VADPT
SET SSNPN=""
+1 SET DAYS=$PIECE(^PSRX(RX,0),"^",8)
SET MFG="________"
SET LOT="________"
STA SET STATE=$SELECT($DATA(^DIC(5,+$PIECE(PS,"^",8),0)):$PIECE(^(0),"^",2),1:"UKN")
+1 SET DRUG=$$ZZ^PSOSUTL(RX)
SET DEA=$PIECE($GET(^PSDRUG(+$PIECE(RXY,"^",6),0)),"^",3)
SET WARN=$PIECE($GET(^(0)),"^",8)
+2 SET SIDE=$SELECT($PIECE($GET(RXRP(RX)),"^",3):1,1:0)
+3 IF $GET(^PSRX(RX,"P",+$GET(RXP),0))]""
SET RXPI=RXP
Begin DoDot:1
+4 SET RXP=^PSRX(RX,"P",RXP,0)
+5 SET RXY=$PIECE(RXP,"^")_"^"_$PIECE(RXY,"^",2,6)_"^"_$PIECE(RXP,"^",4)_"^"_$PIECE(RXP,"^",10)_"^"_...
... $PIECE(RXY,"^",9)_"^"_$PIECE($GET(^PSRX(RX,"SIG")),"^",2)_"^"_$PIECE(RXP,"^",2)_"^"_$PIECE(RXY,"^",12,14)_"^"_$PIECE(^PSRX(RX,"STA"),"^")_"^"_$PIECE(RXP,"^",7)_"^"_$PIECE(RXY,"^",17,99)
+6 SET FDT=$PIECE(RXP,"^")
End DoDot:1
+7 SET MW=$PIECE(RXY,"^",11)
IF $GET(RXFL(RX))'=0
if $GET(RXFL(RX))
Begin DoDot:1
+8 IF $GET(RXFL(RX))
IF '$DATA(^PSRX(RX,1,RXFL(RX),0))
KILL RXFL(RX)
QUIT
+9 ;PSO*7*266
+10 SET RXF=RXFL(RX)
if '$GET(RXP)
SET MW=$PIECE($GET(^PSRX(RX,1,RXF,0)),"^",2)
FOR I=0:0
SET I=$ORDER(^PSRX(RX,1,I))
if 'I
QUIT
IF +^PSRX(RX,1,I,0)'<FDT
SET FDT=+^(0)
End DoDot:1
IF '$GET(RXFL(RX))
FOR I=0:0
SET I=$ORDER(^PSRX(RX,1,I))
if 'I
QUIT
SET RXF=RXF+1
if '$GET(RXP)
SET MW=$PIECE(^PSRX(RX,1,I,0),"^",2)
IF +^PSRX(RX,1,I,0)'<FDT
SET FDT=+^(0)
+11 IF MW="W"
SET PSMP=$GET(^PSRX(RX,"MP"))
IF PSMP]""
Begin DoDot:1
+12 NEW PSJ
SET PSJ=0
FOR PSI=1:1:$LENGTH(PSMP)
SET PSMP(PSI)=""
SET PSJ=PSJ+1
FOR PSJ=PSJ:1
SET PSMP(PSI)=PSMP(PSI)_$PIECE(PSMP," ",PSJ)_" "
if ($LENGTH(PSMP(PSI))+$LENGTH($PIECE(PSMP," ",PSJ+1))>30)
QUIT
+13 KILL PSMP(PSI)
End DoDot:1
+14 SET X=$SELECT($DATA(^PS(55,DFN,0)):^(0),1:"")
SET PSCAP=$PIECE(X,"^",2)
SET PS55=$PIECE($GET(X),"^",3)
SET PS55X=$PIECE($GET(X),"^",5)
+15 IF (($GET(PS55X)]"")&(PS55>1)&(PS55X<DT))
SET PS55=0
+16 ;p753
IF $$GET1^DIQ(52,RX,100.2,"I")]""
SET PS55=$$GET1^DIQ(52,RX,100.2,"I")
SET PS55X=""
+17 if MW="M"
SET MW=$SELECT((PS55=1!(PS55=4)):"R",1:MW)
+18 ;S MW=$S(MW="M":"REGULAR",MW="R":"CERTIFIED",1:"WINDOW") ;COMMENTED OUT V32 LINE OF CODE IN FAVOUR OF FOLLOWING PAPI LINE OF CODE
+19 SET MW=$SELECT(MW="M":"REGULAR",MW="R":"CERTIFIED",MW="P":"PARK",1:"WINDOW")
+20 IF ($GET(PSMP(1))']""&($GET(PS55)=2))
SET PSMP(1)=$GET(SSNPN)
+21 SET DATE=$EXTRACT(FDT,1,7)
SET REF=$PIECE(RXY,"^",9)-RXF
if '$GET(RXP)
SET $PIECE(^PSRX(RX,3),"^")=FDT
if REF<1
SET REF=0
DO ^PSOLBL2
SET II=RX
DO ^PSORFL
DO RFLDT^PSORFL
+22 SET PATST=$GET(^PS(53,+$PIECE(RXY,"^",3),0))
SET PRTFL=1
IF REF=0
if ('$PIECE(PATST,"^",5))!(DEA["W")!(DEA[1)!(DEA[2)
SET PRTFL=0
+23 SET VRPH=$PIECE(^PSRX(RX,2),"^",10)
SET PSCLN=+$PIECE(RXY,"^",5)
SET PSCLN=$SELECT($DATA(^SC(PSCLN,0)):$PIECE(^(0),"^",2),1:"UNKNOWN")
+24 SET PATST=$PIECE(PATST,"^",2)
SET X1=DT
SET X2=$PIECE(RXY,"^",8)-10
if REF
DO C^%DTC
IF $DATA(^PSRX(RX,2))
IF $PIECE(^(2),"^",6)
IF REF
IF X'<$PIECE(^(2),"^",6)
SET REF=0
SET VRPH=$PIECE(^(2),"^",10)
+25 IF $GET(PSOCHAMP)
IF $GET(PSOTRAMT)
SET COPAYVAR="CHAMPUS"
GOTO LBL
+26 IF $GET(RXP)
SET COPAYVAR=""
GOTO LBL
+27 IF $PIECE($GET(^PS(53,+$GET(PSOLBLPS),0)),"^",7)
DO SNO
GOTO LBL
+28 IF $PIECE($GET(^PSDRUG(+$GET(PSOLBLDR),0)),"^",3)["I"!($PIECE($GET(^(0)),"^",3)["S")!($PIECE($GET(^(0)),"^",3)["N")
DO SNO
GOTO LBL
+29 IF $PIECE(^PSRX(RX,"STA"),"^")>0
IF $PIECE(^("STA"),"^")'=2
IF '$GET(PSODBQ)
DO SNO
GOTO LBL
+30 IF $GET(PSOLBLCP)=""
DO IBCP
+31 NEW PSOQI
SET PSOQI=$GET(^PSRX(RX,"IBQ"))
IF $GET(PSOLBLCP)=0
DO SNO
GOTO LBL
+32 IF $GET(PSOLBLCP)=1
IF $PIECE(PSOQI,"^",2)!($PIECE(PSOQI,"^",3))!($PIECE(PSOQI,"^",4))!($PIECE(PSOQI,"^",5))!($PIECE(PSOQI,"^",6))!($PIECE(PSOQI,"^",7))!($PIECE(PSOQI,"^",8))
DO SNO
GOTO LBL
+33 IF $GET(PSOLBLCP)=2
IF $PIECE(PSOQI,"^")!($PIECE(PSOQI,"^",2))!($PIECE(PSOQI,"^",3))!($PIECE(PSOQI,"^",4))!($PIECE(PSOQI,"^",5))!($PIECE(PSOQI,"^",6))!($PIECE(PSOQI,"^",7))!($PIECE(PSOQI,"^",8))
DO SNO
GOTO LBL
+34 IF $GET(PSOLBLCP)=2
IF '$PIECE($GET(^PSRX(RX,"IB")),"^")
DO SNO
GOTO LBL
+35 SET PSOCPN=$PIECE(^PSRX(RX,0),"^",2)
SET INRX=$PIECE(^(0),"^")
IF $GET(^TMP($JOB,"PSOCP",PSOCPN))=""
SET ^(PSOCPN)=PSOCPN
+36 SET ^TMP($JOB,"PSOCP",PSOCPN,INRX)=INRX_"^"_$$ZZ^PSOSUTL(RX)_"^"_+$GET(DAYS)
SET COPAYVAR="COPAY"
KILL ZDRUG
LBL ;
+1 SET PSOSCOPI=$GET(COPIES)
+2 ;critical drug interaction status or dose warning and not a refill or partial - print warning label
if $PIECE(^PSRX(RX,"STA"),"^")=4!($$DS^PSSDSAPI&'$G(RXF)&'$GET(RXP)&$GET(^PS(52.4,RX,1)))
GOTO ^PSOLBLD
+3 ;print warning label for critical and significant interactions
if $DATA(^PSRX(RX,"DRI"))&('$GET(RXF))&('$GET(RXP))
DO ^PSOLBLD
SET COPIES=PSOSCOPI
+4 if $PIECE($GET(^PSRX(RX,3)),"^",6)&('$GET(RXF))&('$GET(RXP))
DO ^PSOLBLD1
+5 if '$PIECE(^PS(59,PSOSITE,1),"^",28)
GOTO ^PSOLBL1
+6 ;already printed warning label above, quit if dose warning and don't print bottle label
IF $$DS^PSSDSAPI
IF '$GET(RXF)
IF '$GET(RXP)
if $DATA(^PS(52.4,RX,1))
QUIT
+7 ;if signficant warning (DRI node piece 1 contains only 2's) continue to print bottle label
if (($PIECE(^PSRX(RX,"STA"),"^")=4!($PIECE($GET(^PSRX(RX,"DRI")),"^",1)[1))&('$GET(RXF))&('$GET(RXP)))
QUIT
+8 SET COPIES=PSOSCOPI
if '$GET(COPIES)
SET COPIES=1
GOTO ^PSOLBLN
REF FOR XXX=0:0
SET XXX=$ORDER(^PSRX(RX,XTYPE,XXX))
if +XXX'>0
QUIT
Begin DoDot:1
+1 SET TECH=$SELECT($DATA(^VA(200,+$PIECE(^PSRX(RX,XTYPE,XXX,0),"^",7),0)):$PIECE(^(0),"^"),1:"UNKNOWN")
+2 SET QTY=$PIECE(^PSRX(RX,XTYPE,XXX,0),"^",4)
SET PHYS=$SELECT($DATA(^VA(200,+$PIECE(^PSRX(RX,XTYPE,XXX,0),"^",17),0)):$PIECE(^(0),"^"),$DATA(^VA(200,+$PIECE(^PSRX(RX,0),"^",4),0)):$PIECE(^(0),"^"),1:"UNKNOWN")
DO 6^VADPT
DO PID^VADPT
SET SSNPN=""
+3 SET DAYS=$PIECE(^PSRX(RX,XTYPE,XXX,0),"^",10)
SET LOT="________"
SET MFG="________"
End DoDot:1
+4 QUIT
CHECK SET PSDFNFLG=0
SET PSOZERO=$PIECE(PPL,",")
SET PSOPDFN=$PIECE(^PSRX(PSOZERO,0),"^",2)
+1 QUIT
OSET DO OSET^PSOLBL1
+1 QUIT
DOUB if '$DATA(RXFL(RX))
QUIT
IF +$GET(RXFL(RX))-PSOCKHNX<0
QUIT
+1 SET RXFLX(RX)=$GET(RXFL(RX))
SET RXFL(RX)=$GET(RXFL(RX))-PSOCKHNX
+2 QUIT
AL(T) NEW I,IR,RF,USR,TY,DES
SET USR=""
+1 IF T="UT"
Begin DoDot:1
+2 NEW J,RX
SET USR=$GET(DUZ)
SET TY="B"
SET DES="Label never queued to print by User"
+3 FOR J=1:1
SET RX=+$PIECE(PPL,",",J)
if 'RX
QUIT
DO AL1
End DoDot:1
+4 IF T="QT"
Begin DoDot:1
+5 SET I=+$PIECE(^PSRX(RX,"STA"),"^")
SET TY=$SELECT((I=3)!(I=16):"H",I=13:"D",1:"C")
+6 SET DES=I_" "_$SELECT((I=3)!(I=16):"HOLD"_$SELECT(I=16:"(PROVIDER)",1:""),(I=12)!(I=14)!(I=15):"DISCONTINUED"_$SELECT(I=14:"(PROVIDER)",I=15:"(EDIT)",1:""),I=13:"DELETED",1:"")
+7 SET DES="Queued label terminated - "_DES
DO AL1
End DoDot:1
+8 KILL %,%H,%I
QUIT
AL1 SET (IR,I,RF)=0
FOR
SET I=$ORDER(^PSRX(RX,1,I))
if 'I
QUIT
SET RF=I
if I>5
SET RF=I+1
+1 SET I=0
FOR
SET I=$ORDER(^PSRX(RX,"A",I))
if 'I
QUIT
SET IR=I
+2 SET IR=IR+1
SET ^PSRX(RX,"A",0)="^52.3DA^"_IR_"^"_IR
+3 DO NOW^%DTC
SET ^PSRX(RX,"A",IR,0)=%_"^"_TY_"^"_USR_"^"_$SELECT($GET(RXPR(RX)):6,1:RF)_"^"_DES
+4 QUIT
IBCP NEW X,Y,PSOJJ,PSOLL
+1 SET PSOLBLCP=""
SET X=$PIECE($GET(^PS(59,+$GET(PSOSITE),"IB")),"^")_"^"_$GET(DFN)
DO XTYPE^IBARX
+2 SET PSOJJ=""
FOR
SET PSOJJ=$ORDER(Y(PSOJJ))
if 'PSOJJ
QUIT
SET PSOLL=""
FOR
SET PSOLL=$ORDER(Y(PSOJJ,PSOLL))
if PSOLL=""
QUIT
if PSOLL>0
SET PSOLBLCP=PSOLL
+3 IF '$GET(PSOLBLCP)
SET PSOLBLCP=0
+4 QUIT
SNO SET COPAYVAR="NO COPAY"
QUIT
