PSOLLLI ;BIR/JLC - LASER LABELS INITIALIZATION ;14-Jun-2013 10:13;PLS
;;7.0;OUTPATIENT PHARMACY;**120,157,1003,1005,1006,1008,1010,189,161,244,200,206,225,303,266,326,1015**;DEC 1997;Build 62
;
;DBIAs PSDRUG-221, PS(55-2228, SC-10040, IBARX-125, PSXSRP-2201, %ZIS-3435, DPT-3097, ^TMP($J,"PSNPPIO"-3794
;External reference to DRUG^PSSWRNA supported by DBIA 4449
;
;*244 remove test for partial fill when testing status > 11
; Modified - IHS/CIA/PLS - 03/06/04
; 05/25/05 - STA+20
; IHS/MSC/PLS - 10/10/07 - Line ORIG, REF+1, OSET+6, OSET+13, C+2
; 02/07/11 - Line STA+22
DQ N PSOBIO S (I,PSOIO)=0 F S I=$O(^%ZIS(2,IOST(0),55,I)) Q:'I S X0=$G(^(I,0)) I X0]"" S PSOIO($P(X0,"^"))=^(1),PSOIO=1
DQ1 I '$D(PPL) G HLEX
; IHS/CIA/PLS - 03/11/04 - Check is to early
;I $P($G(PSOPAR),"^",30)=2,'$G(PSOEXREP) G HLEX
K RXFLX S PSOCKHN=","_$G(PPL),PSRESOLV=+PPL D CHECK
S PSOINT=1 F PI=1:1 S RX=$P(PPL,",",PI) Q:RX="" D
. S RXY=$G(^PSRX(RX,0)) Q:RXY="" I PSOPDFN'=$P(RXY,"^",2),'PSOINT D TRAIL^PSOLLL1 S PSOPDFN=$P(RXY,"^",2)
. K RXP,REPRINT D C
I 'PSOINT D TRAIL^PSOLLL1
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,RXP,REPRINT
K SGY,OSGY,PS2,PSL,PSNP,INRX,RR,XTYPE,SSNP,SSNPN,PNM,ADDR,PSODBQ,PSOLASTF,PSRESOLV,PSOEXREP,PSOSXQ
K DATE,DR,DRUG,LINE,MW,PRTFL,VRPH,EXPDT,X2,DIFF,DAYS,PSZIP,PSOHZIP,PS55,PS55X
K ^TMP($J,"PSNPMI"),^TMP($J,"PSOCP",+$G(PSOCPN)),PSOCPN,PSOLBLDR,PSOLBLPS,PSOLBLCP,RXPR,RXRP,RXRS,PSOCKHN,RXFLX,PSOLAPPL,PSOPDFN,PSDFNFLG,PSOZERO,NEXTRX,PSOBLALL,STA
I '$G(PSOSUREP),'$G(PSOSUSPR) S ZTREQ="@"
Q
C N PSOBIO S (I,PSOIO)=0 F S I=$O(^%ZIS(2,IOST(0),55,I)) Q:'I S X0=$G(^(I,0)) I X0]"" S PSOIO($P(X0,"^"))=^(1),PSOIO=1
U IO Q:'$D(^PSRX(RX,0)) S RXY=^(0),RX2=^(2),RXSTA=^("STA") K SGY,OSGY
Q:(($$FILLDT^APSPFUNC(RX)>$$DT^XLFDT())&($$RXSTAT^APSPFUNC(RX)'=5))
S (SIGM,PFM,PMIM,L2,L3,L4,L5,FILLCONT,BOTTLBL)=0
K SIGF,PFF,PMIF S (SIGF,PFF,PMIF)=0 F I="DR","T" S (SIGF(I),PFF(I))=1
F I="A","B","I" S PMIF(I)=1
D NOW^%DTC S Y=$P(%,"."),PSOFNOW=% X ^DD("DD") S PSONOW=Y,Y=PSOFNOW X ^DD("DD") S PSONOWT=Y
S:$G(PSOBLALL) PSOBLRX=RX S:$D(RXRP(RX)) REPRINT=1 S:$D(RXPR(RX)) RXP=RXPR(RX)
I $G(PSOSUREP)!($G(PSOEXREP)) S REPRINT=1 I '$G(RXRP(RX)) S RXRP(RX)=1
; IHS/CIA/PLS - 03/11/04 - Call External Interface
; 05/25/05 - Moved call to STA+20
;I $$EXTINF^APSPLBL1(RX,$G(REPRINT,0)) I $P($G(PSOPAR),"^",30)=2,'$G(REPRINT) Q ;IHS/CIA/PLS - 03/11/04 - Moved check to here
S A=$P(RXSTA,"^") I A>11 D AL^PSOLBL("QT") K RXP,REPRINT Q ;*244
I A=3 D AL^PSOLBL("QT") K RXP,REPRINT Q
I $G(RXPR(RX)),'$D(^PSRX(RX,"P",RXP,0)) K RXP,REPRINT Q
I $P($G(RXFL(RX)),"^"),'$D(^PSRX(RX,1,$P($G(RXFL(RX)),"^"),0)) K 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 RXP,REPRINT Q
I $G(RXRS(RX))!($G(PSOPULL)) S PSOSXQ=0 N DR,DA,DIE D I $G(PSOSXQ) K RXP,REPRINT Q
. S DA=$O(^PS(52.5,"B",RX,0)) Q:'DA
. S A=$P($G(^PS(52.5,DA,0)),"^",7) I A="" Q
. 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 $P(RXSTA,"^")'=4 D
.I $G(PSOPULL)!($G(RXRS(RX))) D AREC1^PSOSUTL
.I $G(PSOSUSPR) D AREC^PSOSUTL
. I $G(PSOSUREP) D AREC^PSOSUSRP
.; IHS/CIA/PLS - 08/06/04 - Check for CMOP Routine
.I $G(PSXREP) D
..N X S X="PSXSRP" X ^%ZOSF("TEST") I $T D AREC^PSXSRP
S RXY=^PSRX(RX,0),RX2=^(2),RXSTA=^("STA")
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,"^"),DFN=+$P(RXY,"^",2),PSOLBLPS=+$P(RXY,"^",3),PSOLBLDR=+$P(RXY,"^",6)
S ISD=$P(RXY,"^",13),RXF=0,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 NURSE=$S($P($G(^DPT(DFN,"NHC")),"^")="Y":1,$P($G(^PS(55,DFN,40)),"^"):1,1:0)
S FDT=$P(RX2,"^",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=$P(RX2,"^",6),EXDT=$S('EXPDT:"",1:$E(EXPDT,4,5)_"/"_$E(EXPDT,6,7)_"/"_($E(EXPDT,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) D G STA
. I '$G(RXFL(RX)) S XTYPE=1 D REF
I $G(RXP) S XTYPE="P" D REF G STA
ORIG S TECH=$P($G(^VA(200,+$P(RXY,"^",16),0)),"^"),PHYS=$S($D(^VA(200,+$P(RXY,"^",4),0)):$P(^(0),"^"),1:"UKN")
S TECH=$$LBLINI^APSPLBL(RX,"O") ;IHS/MSC/PLS - 10/10/07 - Added line
S DAYS=$P(RXY,"^",8),QTY=$P(RXY,"^",7)
; IHS/CIA/PLS - 03/06/04 - Set to full HRN
D 6^VADPT,PID^VADPT6 S SSNPN=""
S SSNPN=$G(VA("PID")) ;IHS/CIA/PLS - 03/06/04
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 WARN=$$DRUG^PSSWRNA(+$P(RXY,"^",6),+$P(RXY,"^",2))
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",$G(^PSRX(RX,"MP"))]"" D
.S PSMP=^PSRX(RX,"MP"),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)
;New mail codes for CMOP
S MAILCOM=""
S X=$G(^PS(55,DFN,0)),PSCAP=$P(X,"^",2),PS55=$P(X,"^",3),PS55X=$P(X,"^",5)
I PS55X]"",PS55>1,PS55X<DT S PS55=0
S:MW="M" MW=$S((PS55=1!(PS55=4)):"R",1:MW)
S MAILCOM=$P($G(^PS(59,PSOSITE,9)),"^")
S MW=$S(MW="M":"REGULAR",MW="R":"CERTIFIED",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
; IHS/CIA/PLS - 05/25/05 - Call External Interface
I $$EXTINF^APSPLBL1(RX,$G(REPRINT,0)) I $P($G(PSOPAR),"^",30)=2,'$G(REPRINT) Q
;IHS/MSC/PLS - 02/07/2011
;S (X,PSOFLAST)=$G(PSOLASTF) I X?1N.E D ^%DT X ^DD("DD") S PSOFLAST=Y
S (X,PSOFLAST)=$G(PSOLASTF) I X?1N.E N %DT D ^%DT X ^DD("DD") S PSOFLAST=Y
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(RX2,"^",10),PSCLN=+$P(RXY,"^",5),PSCLN=$G(^SC(PSCLN,0)),PSCLN=$S($P(PSCLN,"^",2)'="":$P(PSCLN,"^",2),1:$E($P(PSCLN,"^"),1,7)) I PSCLN="" S PSCLN="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 DEA["I"!(DEA["S")!(DEA["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(RXY,"^",2),INRX=$P(RXY,"^")
I $G(^TMP($J,"PSOCP",PSOCPN))="" S ^(PSOCPN)=PSOCPN
S ^TMP($J,"PSOCP",PSOCPN,INRX)=INRX_"^"_$$ZZ^PSOSUTL(RX)_"^"_+$G(DAYS),COPAYVAR="COPAY" K ZDRUG
LBL I $G(PSOIO("LLI"))]"" X PSOIO("LLI")
I $P(RXSTA,"^")=4 D ^PSOLLL8 Q ;for a critical interaction entered by a tech - don't allow a label to be printed
I $D(^PSRX(RX,"DRI")),'$G(RXF),'$G(RXP) D ^PSOLLL8
I $P($G(^PSRX(RX,3)),"^",6),'$G(RXF),'$G(RXP) D ^PSOLLL9
S PSOINT=0 G ^PSOLLL1
REF F XXX=0:0 S XXX=$O(^PSRX(RX,XTYPE,XXX)) Q:+XXX'>0 D
.; IHS/MSC/PLS - 10/10/07
.;S TECH=$S($D(^VA(200,+$P(^PSRX(RX,XTYPE,XXX,0),"^",7),0)):$P(^(0),"^"),1:"UNKNOWN")
.S TECH=$$LBLINI^APSPLBL(RX,$S(XTYPE:"R",1:"P"),XXX) ;IHS/MSC/PLS - 10/10/07 - Added line
.; IHS/CIA/PLS - 03/06/04 - Set to full HRN
.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^VADPT6 S SSNPN=""
.S SSNPN=$G(VA("PID"))
.S DAYS=$P(^PSRX(RX,XTYPE,XXX,0),"^",10)
Q
CHECK S PSDFNFLG=0,PSOZERO=$P(PPL,","),PSOPDFN=$P(^PSRX(PSOZERO,0),"^",2)
Q
OSET ;
N A
I $G(RXFL(RX))']""!($G(RXFL(RX))=0) D Q
.S A=^PSRX(RX,0)
.; IHS/CIA/PLS - 03/06/04 - Set to full HRN
.S TECH=$P($G(^VA(200,+$P(A,"^",16),0)),"^"),QTY=$P(A,"^",7),PHYS=$S($D(^VA(200,+$P(A,"^",4),0)):$P(^(0),"^"),1:"UKN") D 6^VADPT,PID^VADPT6 S SSNPN=""
.; IHS/MSC/PLS - 10/10/07
.S SSNPN=$G(VA("PID"))
.S TECH=$$LBLINI^APSPLBL(RX,"O")
.S DAYS=$P(A,"^",8)
I '$D(^PSRX(RX,1,RXFL(RX),0)) K RXFL(RX) Q
S A=^PSRX(RX,1,RXFL(RX),0)
; IHS/MSC/PLS - 10/10/07
;S TECH=$S($D(^VA(200,+$P(A,"^",7),0)):$P(^(0),"^"),1:"UNKNOWN")
S TECH=$$LBLINI^APSPLBL(RX,"R",RXFL(RX)) ;IHS/MSC/PLS - 10/10/07 Added line
; IHS/CIA/PLS - 03/06/04 - Set to full HRN
S QTY=$P(A,"^",4),PHYS=$S($D(^VA(200,+$P(A,"^",17),0)):$P(^(0),"^"),$D(^VA(200,+$P(^PSRX(RX,0),"^",4),0)):$P(^(0),"^"),1:"UNKNOWN") D 6^VADPT,PID^VADPT6 S SSNPN=""
S SSNPN=$G(VA("PID"))
S DAYS=$P(A,"^",10)
Q
DOUB ;
Q:'$D(RXFL(RX))
I +$G(RXFL(RX))-PSOCKHNX<0 Q
S RXFLX(RX)=$G(RXFL(RX))
S RXFL(RX)=$G(RXFL(RX))-PSOCKHNX
Q
IBCP ;
N X,Y,PSOJJ,PSOLL
S PSOLBLCP=""
S 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
PSOLLLI ;BIR/JLC - LASER LABELS INITIALIZATION ;14-Jun-2013 10:13;PLS
+1 ;;7.0;OUTPATIENT PHARMACY;**120,157,1003,1005,1006,1008,1010,189,161,244,200,206,225,303,266,326,1015**;DEC 1997;Build 62
+2 ;
+3 ;DBIAs PSDRUG-221, PS(55-2228, SC-10040, IBARX-125, PSXSRP-2201, %ZIS-3435, DPT-3097, ^TMP($J,"PSNPPIO"-3794
+4 ;External reference to DRUG^PSSWRNA supported by DBIA 4449
+5 ;
+6 ;*244 remove test for partial fill when testing status > 11
+7 ; Modified - IHS/CIA/PLS - 03/06/04
+8 ; 05/25/05 - STA+20
+9 ; IHS/MSC/PLS - 10/10/07 - Line ORIG, REF+1, OSET+6, OSET+13, C+2
+10 ; 02/07/11 - Line STA+22
DQ NEW PSOBIO
SET (I,PSOIO)=0
FOR
SET I=$ORDER(^%ZIS(2,IOST(0),55,I))
IF 'I
QUIT
SET X0=$GET(^(I,0))
IF X0]""
SET PSOIO($PIECE(X0,"^"))=^(1)
SET PSOIO=1
DQ1 IF '$DATA(PPL)
GOTO HLEX
+1 ; IHS/CIA/PLS - 03/11/04 - Check is to early
+2 ;I $P($G(PSOPAR),"^",30)=2,'$G(PSOEXREP) G HLEX
+3 KILL RXFLX
SET PSOCKHN=","_$GET(PPL)
SET PSRESOLV=+PPL
DO CHECK
+4 SET PSOINT=1
FOR PI=1:1
SET RX=$PIECE(PPL,",",PI)
IF RX=""
QUIT
Begin DoDot:1
+5 SET RXY=$GET(^PSRX(RX,0))
IF RXY=""
QUIT
IF PSOPDFN'=$PIECE(RXY,"^",2)
IF 'PSOINT
DO TRAIL^PSOLLL1
SET PSOPDFN=$PIECE(RXY,"^",2)
+6 KILL RXP,REPRINT
DO C
End DoDot:1
+7 IF 'PSOINT
DO TRAIL^PSOLLL1
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,RXP,REPRINT
+1 KILL SGY,OSGY,PS2,PSL,PSNP,INRX,RR,XTYPE,SSNP,SSNPN,PNM,ADDR,PSODBQ,PSOLASTF,PSRESOLV,PSOEXREP,PSOSXQ
+2 KILL DATE,DR,DRUG,LINE,MW,PRTFL,VRPH,EXPDT,X2,DIFF,DAYS,PSZIP,PSOHZIP,PS55,PS55X
+3 KILL ^TMP($JOB,"PSNPMI"),^TMP($JOB,"PSOCP",+$GET(PSOCPN)),PSOCPN,PSOLBLDR,PSOLBLPS,PSOLBLCP,RXPR,RXRP,RXRS,PSOCKHN,RXFLX,PSOLAPPL,PSOPDFN,PSDFNFLG,PSOZERO,NEXTRX,PSOBLALL,STA
+4 IF '$GET(PSOSUREP)
IF '$GET(PSOSUSPR)
SET ZTREQ="@"
+5 QUIT
C NEW PSOBIO
SET (I,PSOIO)=0
FOR
SET I=$ORDER(^%ZIS(2,IOST(0),55,I))
IF 'I
QUIT
SET X0=$GET(^(I,0))
IF X0]""
SET PSOIO($PIECE(X0,"^"))=^(1)
SET PSOIO=1
+1 USE IO
IF '$DATA(^PSRX(RX,0))
QUIT
SET RXY=^(0)
SET RX2=^(2)
SET RXSTA=^("STA")
KILL SGY,OSGY
+2 IF (($$FILLDT^APSPFUNC(RX)>$$DT^XLFDT())&($$RXSTAT^APSPFUNC(RX)'=5))
QUIT
+3 SET (SIGM,PFM,PMIM,L2,L3,L4,L5,FILLCONT,BOTTLBL)=0
+4 KILL SIGF,PFF,PMIF
SET (SIGF,PFF,PMIF)=0
FOR I="DR","T"
SET (SIGF(I),PFF(I))=1
+5 FOR I="A","B","I"
SET PMIF(I)=1
+6 DO NOW^%DTC
SET Y=$PIECE(%,".")
SET PSOFNOW=%
XECUTE ^DD("DD")
SET PSONOW=Y
SET Y=PSOFNOW
XECUTE ^DD("DD")
SET PSONOWT=Y
+7 IF $GET(PSOBLALL)
SET PSOBLRX=RX
IF $DATA(RXRP(RX))
SET REPRINT=1
IF $DATA(RXPR(RX))
SET RXP=RXPR(RX)
+8 IF $GET(PSOSUREP)!($GET(PSOEXREP))
SET REPRINT=1
IF '$GET(RXRP(RX))
SET RXRP(RX)=1
+9 ; IHS/CIA/PLS - 03/11/04 - Call External Interface
+10 ; 05/25/05 - Moved call to STA+20
+11 ;I $$EXTINF^APSPLBL1(RX,$G(REPRINT,0)) I $P($G(PSOPAR),"^",30)=2,'$G(REPRINT) Q ;IHS/CIA/PLS - 03/11/04 - Moved check to here
+12 ;*244
SET A=$PIECE(RXSTA,"^")
IF A>11
DO AL^PSOLBL("QT")
KILL RXP,REPRINT
QUIT
+13 IF A=3
DO AL^PSOLBL("QT")
KILL RXP,REPRINT
QUIT
+14 IF $GET(RXPR(RX))
IF '$DATA(^PSRX(RX,"P",RXP,0))
KILL RXP,REPRINT
QUIT
+15 IF $PIECE($GET(RXFL(RX)),"^")
IF '$DATA(^PSRX(RX,1,$PIECE($GET(RXFL(RX)),"^"),0))
KILL RXP,REPRINT
QUIT
+16 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 RXP,REPRINT
QUIT
+17 IF $GET(RXRS(RX))!($GET(PSOPULL))
SET PSOSXQ=0
NEW DR,DA,DIE
Begin DoDot:1
+18 SET DA=$ORDER(^PS(52.5,"B",RX,0))
IF 'DA
QUIT
+19 SET A=$PIECE($GET(^PS(52.5,DA,0)),"^",7)
IF A=""
QUIT
+20 IF A="Q"
SET DIE="^PS(52.5,"
SET DR="3////P"
DO ^DIE
QUIT
+21 KILL RXRS(RX)
SET PSOSXQ=1
End DoDot:1
IF $GET(PSOSXQ)
KILL RXP,REPRINT
QUIT
+22 IF $GET(PSRESOLV)=RX
DO ENLBL^PSOBSET
KILL PSRESOLV
+23 IF $PIECE(RXSTA,"^")'=4
Begin DoDot:1
+24 IF $GET(PSOPULL)!($GET(RXRS(RX)))
DO AREC1^PSOSUTL
+25 IF $GET(PSOSUSPR)
DO AREC^PSOSUTL
+26 IF $GET(PSOSUREP)
DO AREC^PSOSUSRP
+27 ; IHS/CIA/PLS - 08/06/04 - Check for CMOP Routine
+28 IF $GET(PSXREP)
Begin DoDot:2
+29 NEW X
SET X="PSXSRP"
XECUTE ^%ZOSF("TEST")
IF $TEST
DO AREC^PSXSRP
End DoDot:2
End DoDot:1
+30 SET RXY=^PSRX(RX,0)
SET RX2=^(2)
SET RXSTA=^("STA")
+31 KILL ^UTILITY("DIQ1",$JOB)
SET DA=$PIECE($$SITE^VASITE(),"^")
+32 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
+33 SET RXN=$PIECE(RXY,"^")
SET DFN=+$PIECE(RXY,"^",2)
SET PSOLBLPS=+$PIECE(RXY,"^",3)
SET PSOLBLDR=+$PIECE(RXY,"^",6)
+34 SET ISD=$PIECE(RXY,"^",13)
SET RXF=0
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)="_"
+35 SET NURSE=$SELECT($PIECE($GET(^DPT(DFN,"NHC")),"^")="Y":1,$PIECE($GET(^PS(55,DFN,40)),"^"):1,1:0)
+36 SET FDT=$PIECE(RX2,"^",2)
SET PS=$SELECT($DATA(^PS(59,PSOSITE,0)):^(0),1:"")
SET PS1=$SELECT($DATA(^(1)):^(1),1:"")
SET PSOSITE7=$PIECE(^("IB"),"^")
+37 SET PS2=$PIECE(PS,"^")_"^"_$PIECE(PS,"^",6)
+38 SET EXPDT=$PIECE(RX2,"^",6)
SET EXDT=$SELECT('EXPDT:"",1:$EXTRACT(EXPDT,4,5)_"/"_$EXTRACT(EXPDT,6,7)_"/"_($EXTRACT(EXPDT,1,3)+1700))
+39 SET COPIES=$SELECT($PIECE($GET(RXRP(RX)),"^",2):$PIECE($GET(RXRP(RX)),"^",2),$PIECE(RXY,"^",18)]"":$PIECE(RXY,"^",18),1:1)
+40 KILL PSOCKHNX
SET PSOCKHL=$LENGTH(RX)
SET PSOCKHN=$EXTRACT($GET(PSOCKHN),(PSOCKHL+2),999)
Begin DoDot:1
+41 SET PSOCKHA=","_RX_","
+42 IF PSOCKHN'[PSOCKHA
QUIT
+43 SET PSOCKHA=$EXTRACT(PSOCKHA,1,($LENGTH(PSOCKHA)-1))
+44 SET PSOCKHNX=$LENGTH(PSOCKHN,PSOCKHA)-1
+45 IF +$GET(PSOCKHNX)>0
DO DOUB
End DoDot:1
KILL PSOCKHNX,PSOCKHL,PSOCKHA
+46 IF $ORDER(^PSRX(RX,1,0))
IF $GET(RXFL(RX))'=0
SET $PIECE(^PSRX(RX,3),"^",6)=""
KILL ^PSRX(RX,"DAI"),^PSRX(RX,"DRI")
+47 IF '$GET(RXP)
IF '$ORDER(^PSRX(RX,1,0))
SET RXFL(RX)=0
+48 IF '$GET(RXP)
DO OSET
IF '$ORDER(^PSRX(RX,1,0))!($GET(RXFL(RX))=0)
GOTO ORIG
+49 IF $ORDER(^PSRX(RX,1,0))
IF '$GET(RXP)
Begin DoDot:1
+50 IF '$GET(RXFL(RX))
SET XTYPE=1
DO REF
End DoDot:1
GOTO STA
+51 IF $GET(RXP)
SET XTYPE="P"
DO REF
GOTO STA
ORIG SET TECH=$PIECE($GET(^VA(200,+$PIECE(RXY,"^",16),0)),"^")
SET PHYS=$SELECT($DATA(^VA(200,+$PIECE(RXY,"^",4),0)):$PIECE(^(0),"^"),1:"UKN")
+1 ;IHS/MSC/PLS - 10/10/07 - Added line
SET TECH=$$LBLINI^APSPLBL(RX,"O")
+2 SET DAYS=$PIECE(RXY,"^",8)
SET QTY=$PIECE(RXY,"^",7)
+3 ; IHS/CIA/PLS - 03/06/04 - Set to full HRN
+4 DO 6^VADPT
DO PID^VADPT6
SET SSNPN=""
+5 ;IHS/CIA/PLS - 03/06/04
SET SSNPN=$GET(VA("PID"))
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 WARN=$$DRUG^PSSWRNA(+$PIECE(RXY,"^",6),+$PIECE(RXY,"^",2))
+3 SET SIDE=$SELECT($PIECE($GET(RXRP(RX)),"^",3):1,1:0)
+4 IF $GET(^PSRX(RX,"P",+$GET(RXP),0))]""
SET RXPI=RXP
Begin DoDot:1
+5 SET RXP=^PSRX(RX,"P",RXP,0)
+6 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)
+7 SET FDT=$PIECE(RXP,"^")
End DoDot:1
+8 SET MW=$PIECE(RXY,"^",11)
IF $GET(RXFL(RX))'=0
IF $GET(RXFL(RX))
Begin DoDot:1
+9 IF $GET(RXFL(RX))
IF '$DATA(^PSRX(RX,1,RXFL(RX),0))
KILL RXFL(RX)
QUIT
+10 ;PSO*7*266
+11 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)
+12 IF MW="W"
IF $GET(^PSRX(RX,"MP"))]""
Begin DoDot:1
+13 SET PSMP=^PSRX(RX,"MP")
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
+14 KILL PSMP(PSI)
End DoDot:1
+15 ;New mail codes for CMOP
+16 SET MAILCOM=""
+17 SET X=$GET(^PS(55,DFN,0))
SET PSCAP=$PIECE(X,"^",2)
SET PS55=$PIECE(X,"^",3)
SET PS55X=$PIECE(X,"^",5)
+18 IF PS55X]""
IF PS55>1
IF PS55X<DT
SET PS55=0
+19 IF MW="M"
SET MW=$SELECT((PS55=1!(PS55=4)):"R",1:MW)
+20 SET MAILCOM=$PIECE($GET(^PS(59,PSOSITE,9)),"^")
+21 SET MW=$SELECT(MW="M":"REGULAR",MW="R":"CERTIFIED",1:"WINDOW")
+22 IF $GET(PSMP(1))=""
IF $GET(PS55)=2
SET PSMP(1)=$GET(SSNPN)
+23 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
+24 ; IHS/CIA/PLS - 05/25/05 - Call External Interface
+25 IF $$EXTINF^APSPLBL1(RX,$GET(REPRINT,0))
IF $PIECE($GET(PSOPAR),"^",30)=2
IF '$GET(REPRINT)
QUIT
+26 ;IHS/MSC/PLS - 02/07/2011
+27 ;S (X,PSOFLAST)=$G(PSOLASTF) I X?1N.E D ^%DT X ^DD("DD") S PSOFLAST=Y
+28 SET (X,PSOFLAST)=$GET(PSOLASTF)
IF X?1N.E
NEW %DT
DO ^%DT
XECUTE ^DD("DD")
SET PSOFLAST=Y
+29 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
+30 SET VRPH=$PIECE(RX2,"^",10)
SET PSCLN=+$PIECE(RXY,"^",5)
SET PSCLN=$GET(^SC(PSCLN,0))
SET PSCLN=$SELECT($PIECE(PSCLN,"^",2)'="":$PIECE(PSCLN,"^",2),1:$EXTRACT($PIECE(PSCLN,"^"),1,7))
IF PSCLN=""
SET PSCLN="UNKNOWN"
+31 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)
+32 IF $GET(PSOCHAMP)
IF $GET(PSOTRAMT)
SET COPAYVAR="CHAMPUS"
GOTO LBL
+33 IF $GET(RXP)
SET COPAYVAR=""
GOTO LBL
+34 IF $PIECE($GET(^PS(53,+$GET(PSOLBLPS),0)),"^",7)
DO SNO
GOTO LBL
+35 IF DEA["I"!(DEA["S")!(DEA["N")
DO SNO
GOTO LBL
+36 IF $PIECE(^PSRX(RX,"STA"),"^")>0
IF $PIECE(^("STA"),"^")'=2
IF '$GET(PSODBQ)
DO SNO
GOTO LBL
+37 IF $GET(PSOLBLCP)=""
DO IBCP
+38 NEW PSOQI
SET PSOQI=$GET(^PSRX(RX,"IBQ"))
+39 IF $GET(PSOLBLCP)=0
DO SNO
GOTO LBL
+40 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
+41 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
+42 IF $GET(PSOLBLCP)=2
IF '$PIECE($GET(^PSRX(RX,"IB")),"^")
DO SNO
GOTO LBL
+43 SET PSOCPN=$PIECE(RXY,"^",2)
SET INRX=$PIECE(RXY,"^")
+44 IF $GET(^TMP($JOB,"PSOCP",PSOCPN))=""
SET ^(PSOCPN)=PSOCPN
+45 SET ^TMP($JOB,"PSOCP",PSOCPN,INRX)=INRX_"^"_$$ZZ^PSOSUTL(RX)_"^"_+$GET(DAYS)
SET COPAYVAR="COPAY"
KILL ZDRUG
LBL IF $GET(PSOIO("LLI"))]""
XECUTE PSOIO("LLI")
+1 ;for a critical interaction entered by a tech - don't allow a label to be printed
IF $PIECE(RXSTA,"^")=4
DO ^PSOLLL8
QUIT
+2 IF $DATA(^PSRX(RX,"DRI"))
IF '$GET(RXF)
IF '$GET(RXP)
DO ^PSOLLL8
+3 IF $PIECE($GET(^PSRX(RX,3)),"^",6)
IF '$GET(RXF)
IF '$GET(RXP)
DO ^PSOLLL9
+4 SET PSOINT=0
GOTO ^PSOLLL1
REF FOR XXX=0:0
SET XXX=$ORDER(^PSRX(RX,XTYPE,XXX))
IF +XXX'>0
QUIT
Begin DoDot:1
+1 ; IHS/MSC/PLS - 10/10/07
+2 ;S TECH=$S($D(^VA(200,+$P(^PSRX(RX,XTYPE,XXX,0),"^",7),0)):$P(^(0),"^"),1:"UNKNOWN")
+3 ;IHS/MSC/PLS - 10/10/07 - Added line
SET TECH=$$LBLINI^APSPLBL(RX,$SELECT(XTYPE:"R",1:"P"),XXX)
+4 ; IHS/CIA/PLS - 03/06/04 - Set to full HRN
+5 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^VADPT6
SET SSNPN=""
+6 SET SSNPN=$GET(VA("PID"))
+7 SET DAYS=$PIECE(^PSRX(RX,XTYPE,XXX,0),"^",10)
End DoDot:1
+8 QUIT
CHECK SET PSDFNFLG=0
SET PSOZERO=$PIECE(PPL,",")
SET PSOPDFN=$PIECE(^PSRX(PSOZERO,0),"^",2)
+1 QUIT
OSET ;
+1 NEW A
+2 IF $GET(RXFL(RX))']""!($GET(RXFL(RX))=0)
Begin DoDot:1
+3 SET A=^PSRX(RX,0)
+4 ; IHS/CIA/PLS - 03/06/04 - Set to full HRN
+5 SET TECH=$PIECE($GET(^VA(200,+$PIECE(A,"^",16),0)),"^")
SET QTY=$PIECE(A,"^",7)
SET PHYS=$SELECT($DATA(^VA(200,+$PIECE(A,"^",4),0)):$PIECE(^(0),"^"),1:"UKN")
DO 6^VADPT
DO PID^VADPT6
SET SSNPN=""
+6 ; IHS/MSC/PLS - 10/10/07
+7 SET SSNPN=$GET(VA("PID"))
+8 SET TECH=$$LBLINI^APSPLBL(RX,"O")
+9 SET DAYS=$PIECE(A,"^",8)
End DoDot:1
QUIT
+10 IF '$DATA(^PSRX(RX,1,RXFL(RX),0))
KILL RXFL(RX)
QUIT
+11 SET A=^PSRX(RX,1,RXFL(RX),0)
+12 ; IHS/MSC/PLS - 10/10/07
+13 ;S TECH=$S($D(^VA(200,+$P(A,"^",7),0)):$P(^(0),"^"),1:"UNKNOWN")
+14 ;IHS/MSC/PLS - 10/10/07 Added line
SET TECH=$$LBLINI^APSPLBL(RX,"R",RXFL(RX))
+15 ; IHS/CIA/PLS - 03/06/04 - Set to full HRN
+16 SET QTY=$PIECE(A,"^",4)
SET PHYS=$SELECT($DATA(^VA(200,+$PIECE(A,"^",17),0)):$PIECE(^(0),"^"),$DATA(^VA(200,+$PIECE(^PSRX(RX,0),"^",4),0)):$PIECE(^(0),"^"),1:"UNKNOWN")
DO 6^VADPT
DO PID^VADPT6
SET SSNPN=""
+17 SET SSNPN=$GET(VA("PID"))
+18 SET DAYS=$PIECE(A,"^",10)
+19 QUIT
DOUB ;
+1 IF '$DATA(RXFL(RX))
QUIT
+2 IF +$GET(RXFL(RX))-PSOCKHNX<0
QUIT
+3 SET RXFLX(RX)=$GET(RXFL(RX))
+4 SET RXFL(RX)=$GET(RXFL(RX))-PSOCKHNX
+5 QUIT
IBCP ;
+1 NEW X,Y,PSOJJ,PSOLL
+2 SET PSOLBLCP=""
+3 SET X=$PIECE($GET(^PS(59,+$GET(PSOSITE),"IB")),"^")_"^"_$GET(DFN)
DO XTYPE^IBARX
+4 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
+5 IF '$GET(PSOLBLCP)
SET PSOLBLCP=0
+6 QUIT
SNO ;
+1 SET COPAYVAR="NO COPAY"
+2 QUIT
