- PSOLLLI ;BIR/JLC - LASER LABELS INITIALIZATION ;11/20/08 12:17pm
- ;;7.0;OUTPATIENT PHARMACY;**120,157,189,161,244,200,206,225,303,266,326,251,387,367,753**;DEC 1997;Build 53
- ;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
- ;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 $$DS^PSSDSAPI supported by DBIA 5425
- ;
- ;*244 remove test for partial fill when testing status > 11
- ;
- 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
- I $P($G(PSOPAR),"^",30)=2,'$G(PSOEXREP) G HLEX
- K RXFLX,RXFDAMG 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
- ;
- ; Printing FDA Medication Guides
- N FDARX,FDAMG
- S FDARX="" F S FDARX=$O(RXFDAMG(FDARX)) Q:FDARX="" D
- . S FDAMG=$$PRINTMG^PSOFDAMG(FDARX,$P($G(PSOFDAPT),"^",2))
- ;
- 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,REF
- 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
- 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 S:$G(PSOMGREP) RXRP(RX,"MG")=1
- 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(PSOSUSPR) D AREC^PSOSUTL
- . I $G(PSOPULL)!($G(RXRS(RX))) D AREC1^PSOSUTL
- . I $G(PSOSUREP) D AREC^PSOSUSRP
- . I $G(PSXREP) 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 DAYS=$P(RXY,"^",8),QTY=$P(RXY,"^",7)
- D 6^VADPT,PID^VADPT6 S SSNPN=""
- 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
- .N PSJ 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
- 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 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
- S (X,PSOFLAST)=$G(PSOLASTF) I X?1N.E 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")
- ;
- N PSODDFLG,PSODWARN,PSOSIGNIF S PSODWARN=0 D
- .I $D(^PSRX(RX,"DRI")),$P(^PSRX(RX,"DRI"),"^")[1 S PSODWARN=1 ;must have a critical drug interaction to print tech warning label
- .I '$D(^PSRX(RX,"DRI")),$D(^PS(52.4,RX,0)),$P(^PS(52.4,RX,0),"^",9)[1 S PSODWARN=1 ;must have a critical drug interaction to print tech warning label
- .I $D(^PS(52.4,RX,0)),$P(^PS(52.4,RX,0),"^",9)'[1,$P(^PS(52.4,RX,0),"^",9)[2 S PSOSIGNIF=1
- .I $$DS^PSSDSAPI,($D(^PS(52.4,RX,1))) S PSODWARN=1 ;dose warnings should print a tech warning label
- ;
- G ^PSOLLL8:($P(RXSTA,"^")=4!$G(PSODWARN))&'$G(RXF)&'$G(RXP) ;print warning label for critical interaction and dose warnings
- I '$G(PSODGETA) D ^PSOLLL8:$D(^PSRX(RX,"DRI"))&('$G(RXF))&('$G(RXP)) ;print warning label for significant interactions
- I '$G(PSODGETA),$G(PSOSIGNIF),$D(^PSRX(RX,"DRI"))&('$G(RXF))&('$G(RXP)) S PSODGETA=1 D C
- K PSODGETA
- 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)))
- ;
- LBL2 ;
- 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
- .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^VADPT6 S SSNPN=""
- .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)
- .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=""
- .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)
- S TECH=$S($D(^VA(200,+$P(A,"^",7),0)):$P(^(0),"^"),1:"UNKNOWN")
- 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 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOLLLI 10959 printed Feb 18, 2025@23:57:08 Page 2
- PSOLLLI ;BIR/JLC - LASER LABELS INITIALIZATION ;11/20/08 12:17pm
- +1 ;;7.0;OUTPATIENT PHARMACY;**120,157,189,161,244,200,206,225,303,266,326,251,387,367,753**;DEC 1997;Build 53
- +2 ;DBIAs PSDRUG-221, PS(55-2228, SC-10040, IBARX-125, PSXSRP-2201, %ZIS-3435, DPT-3097, ^TMP($J,"PSNPPIO"-3794
- +3 ;External reference to DRUG^PSSWRNA supported by DBIA 4449
- +4 ;External reference to $$DS^PSSDSAPI supported by DBIA 5425
- +5 ;External reference to ^DIC(5 supported by DBIA 4293
- +6 ;External reference to ^SC( supported by DBIA 2675
- +7 ;External reference to $$DS^PSSDSAPI supported by DBIA 5425
- +8 ;
- +9 ;*244 remove test for partial fill when testing status > 11
- +10 ;
- 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 IF $PIECE($GET(PSOPAR),"^",30)=2
- IF '$GET(PSOEXREP)
- GOTO HLEX
- +2 KILL RXFLX,RXFDAMG
- SET PSOCKHN=","_$GET(PPL)
- SET PSRESOLV=+PPL
- DO CHECK
- +3 SET PSOINT=1
- FOR PI=1:1
- SET RX=$PIECE(PPL,",",PI)
- if RX=""
- QUIT
- Begin DoDot:1
- +4 SET RXY=$GET(^PSRX(RX,0))
- if RXY=""
- QUIT
- IF PSOPDFN'=$PIECE(RXY,"^",2)
- IF 'PSOINT
- DO TRAIL^PSOLLL1
- SET PSOPDFN=$PIECE(RXY,"^",2)
- +5 KILL RXP,REPRINT
- DO C
- End DoDot:1
- +6 IF 'PSOINT
- DO TRAIL^PSOLLL1
- +7 ;
- +8 ; Printing FDA Medication Guides
- +9 NEW FDARX,FDAMG
- +10 SET FDARX=""
- FOR
- SET FDARX=$ORDER(RXFDAMG(FDARX))
- if FDARX=""
- QUIT
- Begin DoDot:1
- +11 SET FDAMG=$$PRINTMG^PSOFDAMG(FDARX,$PIECE($GET(PSOFDAPT),"^",2))
- End DoDot:1
- +12 ;
- 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,REF
- +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
- +6 ;
- 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 SET (SIGM,PFM,PMIM,L2,L3,L4,L5,FILLCONT,BOTTLBL)=0
- +3 KILL SIGF,PFF,PMIF
- SET (SIGF,PFF,PMIF)=0
- FOR I="DR","T"
- SET (SIGF(I),PFF(I))=1
- +4 FOR I="A","B","I"
- SET PMIF(I)=1
- +5 DO NOW^%DTC
- SET Y=$PIECE(%,".")
- SET PSOFNOW=%
- XECUTE ^DD("DD")
- SET PSONOW=Y
- SET Y=PSOFNOW
- XECUTE ^DD("DD")
- SET PSONOWT=Y
- +6 if $GET(PSOBLALL)
- SET PSOBLRX=RX
- if $DATA(RXRP(RX))
- SET REPRINT=1
- if $DATA(RXPR(RX))
- SET RXP=RXPR(RX)
- +7 IF $GET(PSOSUREP)!($GET(PSOEXREP))
- SET REPRINT=1
- IF '$GET(RXRP(RX))
- SET RXRP(RX)=1
- if $GET(PSOMGREP)
- SET RXRP(RX,"MG")=1
- +8 ;*244
- SET A=$PIECE(RXSTA,"^")
- IF A>11
- DO AL^PSOLBL("QT")
- KILL RXP,REPRINT
- QUIT
- +9 IF A=3
- DO AL^PSOLBL("QT")
- KILL RXP,REPRINT
- QUIT
- +10 IF $GET(RXPR(RX))
- IF '$DATA(^PSRX(RX,"P",RXP,0))
- KILL RXP,REPRINT
- QUIT
- +11 IF $PIECE($GET(RXFL(RX)),"^")
- IF '$DATA(^PSRX(RX,1,$PIECE($GET(RXFL(RX)),"^"),0))
- KILL RXP,REPRINT
- QUIT
- +12 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
- +13 IF $GET(RXRS(RX))!($GET(PSOPULL))
- SET PSOSXQ=0
- NEW DR,DA,DIE
- Begin DoDot:1
- +14 SET DA=$ORDER(^PS(52.5,"B",RX,0))
- if 'DA
- QUIT
- +15 SET A=$PIECE($GET(^PS(52.5,DA,0)),"^",7)
- IF A=""
- QUIT
- +16 IF A="Q"
- SET DIE="^PS(52.5,"
- SET DR="3////P"
- DO ^DIE
- QUIT
- +17 KILL RXRS(RX)
- SET PSOSXQ=1
- End DoDot:1
- IF $GET(PSOSXQ)
- KILL RXP,REPRINT
- QUIT
- +18 IF $GET(PSRESOLV)=RX
- DO ENLBL^PSOBSET
- KILL PSRESOLV
- +19 IF $PIECE(RXSTA,"^")'=4
- Begin DoDot:1
- +20 IF $GET(PSOSUSPR)
- DO AREC^PSOSUTL
- +21 IF $GET(PSOPULL)!($GET(RXRS(RX)))
- DO AREC1^PSOSUTL
- +22 IF $GET(PSOSUREP)
- DO AREC^PSOSUSRP
- +23 IF $GET(PSXREP)
- DO AREC^PSXSRP
- End DoDot:1
- +24 SET RXY=^PSRX(RX,0)
- SET RX2=^(2)
- SET RXSTA=^("STA")
- +25 KILL ^UTILITY("DIQ1",$JOB)
- SET DA=$PIECE($$SITE^VASITE(),"^")
- +26 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
- +27 SET RXN=$PIECE(RXY,"^")
- SET DFN=+$PIECE(RXY,"^",2)
- SET PSOLBLPS=+$PIECE(RXY,"^",3)
- SET PSOLBLDR=+$PIECE(RXY,"^",6)
- +28 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)="_"
- +29 SET NURSE=$SELECT($PIECE($GET(^DPT(DFN,"NHC")),"^")="Y":1,$PIECE($GET(^PS(55,DFN,40)),"^"):1,1:0)
- +30 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"),"^")
- +31 SET PS2=$PIECE(PS,"^")_"^"_$PIECE(PS,"^",6)
- +32 SET EXPDT=$PIECE(RX2,"^",6)
- SET EXDT=$SELECT('EXPDT:"",1:$EXTRACT(EXPDT,4,5)_"/"_$EXTRACT(EXPDT,6,7)_"/"_($EXTRACT(EXPDT,1,3)+1700))
- +33 SET COPIES=$SELECT($PIECE($GET(RXRP(RX)),"^",2):$PIECE($GET(RXRP(RX)),"^",2),$PIECE(RXY,"^",18)]"":$PIECE(RXY,"^",18),1:1)
- +34 KILL PSOCKHNX
- SET PSOCKHL=$LENGTH(RX)
- SET PSOCKHN=$EXTRACT($GET(PSOCKHN),(PSOCKHL+2),999)
- Begin DoDot:1
- +35 SET PSOCKHA=","_RX_","
- +36 IF PSOCKHN'[PSOCKHA
- QUIT
- +37 SET PSOCKHA=$EXTRACT(PSOCKHA,1,($LENGTH(PSOCKHA)-1))
- +38 SET PSOCKHNX=$LENGTH(PSOCKHN,PSOCKHA)-1
- +39 IF +$GET(PSOCKHNX)>0
- DO DOUB
- End DoDot:1
- KILL PSOCKHNX,PSOCKHL,PSOCKHA
- +40 IF $ORDER(^PSRX(RX,1,0))
- IF $GET(RXFL(RX))'=0
- SET $PIECE(^PSRX(RX,3),"^",6)=""
- KILL ^PSRX(RX,"DAI"),^PSRX(RX,"DRI")
- +41 IF '$GET(RXP)
- IF '$ORDER(^PSRX(RX,1,0))
- SET RXFL(RX)=0
- +42 IF '$GET(RXP)
- DO OSET
- IF '$ORDER(^PSRX(RX,1,0))!($GET(RXFL(RX))=0)
- GOTO ORIG
- +43 IF $ORDER(^PSRX(RX,1,0))
- IF '$GET(RXP)
- Begin DoDot:1
- +44 IF '$GET(RXFL(RX))
- SET XTYPE=1
- DO REF
- End DoDot:1
- GOTO STA
- +45 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 SET DAYS=$PIECE(RXY,"^",8)
- SET QTY=$PIECE(RXY,"^",7)
- +2 DO 6^VADPT
- DO PID^VADPT6
- SET SSNPN=""
- STA ;
- +1 SET STATE=$SELECT($DATA(^DIC(5,+$PIECE(PS,"^",8),0)):$PIECE(^(0),"^",2),1:"UKN")
- +2 SET DRUG=$$ZZ^PSOSUTL(RX)
- SET DEA=$PIECE($GET(^PSDRUG(+$PIECE(RXY,"^",6),0)),"^",3)
- SET WARN=$PIECE($GET(^(0)),"^",8)
- +3 SET WARN=$$DRUG^PSSWRNA(+$PIECE(RXY,"^",6),+$PIECE(RXY,"^",2))
- +4 SET SIDE=$SELECT($PIECE($GET(RXRP(RX)),"^",3):1,1:0)
- +5 IF $GET(^PSRX(RX,"P",+$GET(RXP),0))]""
- SET RXPI=RXP
- Begin DoDot:1
- +6 SET RXP=^PSRX(RX,"P",RXP,0)
- +7 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)
- +8 SET FDT=$PIECE(RXP,"^")
- End DoDot:1
- +9 SET MW=$PIECE(RXY,"^",11)
- IF $GET(RXFL(RX))'=0
- if $GET(RXFL(RX))
- Begin DoDot:1
- +10 IF $GET(RXFL(RX))
- IF '$DATA(^PSRX(RX,1,RXFL(RX),0))
- KILL RXFL(RX)
- QUIT
- +11 ;PSO*7*266
- +12 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)
- +13 IF MW="W"
- IF $GET(^PSRX(RX,"MP"))]""
- Begin DoDot:1
- +14 NEW PSJ
- 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
- +15 KILL PSMP(PSI)
- End DoDot:1
- +16 ;New mail codes for CMOP
- +17 SET MAILCOM=""
- +18 SET X=$GET(^PS(55,DFN,0))
- SET PSCAP=$PIECE(X,"^",2)
- SET PS55=$PIECE(X,"^",3)
- SET PS55X=$PIECE(X,"^",5)
- +19 IF PS55X]""
- IF PS55>1
- IF PS55X<DT
- SET PS55=0
- +20 ;p753
- IF $$GET1^DIQ(52,RX,100.2,"I")]""
- SET PS55=$$GET1^DIQ(52,RX,100.2,"I")
- SET PS55X=""
- +21 if MW="M"
- SET MW=$SELECT((PS55=1!(PS55=4)):"R",1:MW)
- +22 SET MAILCOM=$PIECE($GET(^PS(59,PSOSITE,9)),"^")
- +23 SET MW=$SELECT(MW="M":"REGULAR",MW="R":"CERTIFIED",1:"WINDOW")
- +24 IF $GET(PSMP(1))=""
- IF $GET(PS55)=2
- SET PSMP(1)=$GET(SSNPN)
- +25 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
- +26 SET (X,PSOFLAST)=$GET(PSOLASTF)
- IF X?1N.E
- DO ^%DT
- XECUTE ^DD("DD")
- SET PSOFLAST=Y
- +27 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
- +28 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"
- +29 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)
- +30 IF $GET(PSOCHAMP)
- IF $GET(PSOTRAMT)
- SET COPAYVAR="CHAMPUS"
- GOTO LBL
- +31 IF $GET(RXP)
- SET COPAYVAR=""
- GOTO LBL
- +32 IF $PIECE($GET(^PS(53,+$GET(PSOLBLPS),0)),"^",7)
- DO SNO
- GOTO LBL
- +33 IF DEA["I"!(DEA["S")!(DEA["N")
- DO SNO
- GOTO LBL
- +34 IF $PIECE(^PSRX(RX,"STA"),"^")>0
- IF $PIECE(^("STA"),"^")'=2
- IF '$GET(PSODBQ)
- DO SNO
- GOTO LBL
- +35 IF $GET(PSOLBLCP)=""
- DO IBCP
- +36 NEW PSOQI
- SET PSOQI=$GET(^PSRX(RX,"IBQ"))
- +37 IF $GET(PSOLBLCP)=0
- DO SNO
- GOTO LBL
- +38 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
- +39 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
- +40 IF $GET(PSOLBLCP)=2
- IF '$PIECE($GET(^PSRX(RX,"IB")),"^")
- DO SNO
- GOTO LBL
- +41 SET PSOCPN=$PIECE(RXY,"^",2)
- SET INRX=$PIECE(RXY,"^")
- +42 IF $GET(^TMP($JOB,"PSOCP",PSOCPN))=""
- SET ^(PSOCPN)=PSOCPN
- +43 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 ;
- +2 NEW PSODDFLG,PSODWARN,PSOSIGNIF
- SET PSODWARN=0
- Begin DoDot:1
- +3 ;must have a critical drug interaction to print tech warning label
- IF $DATA(^PSRX(RX,"DRI"))
- IF $PIECE(^PSRX(RX,"DRI"),"^")[1
- SET PSODWARN=1
- +4 ;must have a critical drug interaction to print tech warning label
- IF '$DATA(^PSRX(RX,"DRI"))
- IF $DATA(^PS(52.4,RX,0))
- IF $PIECE(^PS(52.4,RX,0),"^",9)[1
- SET PSODWARN=1
- +5 IF $DATA(^PS(52.4,RX,0))
- IF $PIECE(^PS(52.4,RX,0),"^",9)'[1
- IF $PIECE(^PS(52.4,RX,0),"^",9)[2
- SET PSOSIGNIF=1
- +6 ;dose warnings should print a tech warning label
- IF $$DS^PSSDSAPI
- IF ($DATA(^PS(52.4,RX,1)))
- SET PSODWARN=1
- End DoDot:1
- +7 ;
- +8 ;print warning label for critical interaction and dose warnings
- if ($PIECE(RXSTA,"^")=4!$GET(PSODWARN))&'$GET(RXF)&'$GET(RXP)
- GOTO ^PSOLLL8
- +9 ;print warning label for significant interactions
- IF '$GET(PSODGETA)
- if $DATA(^PSRX(RX,"DRI"))&('$GET(RXF))&('$GET(RXP))
- DO ^PSOLLL8
- +10 IF '$GET(PSODGETA)
- IF $GET(PSOSIGNIF)
- IF $DATA(^PSRX(RX,"DRI"))&('$GET(RXF))&('$GET(RXP))
- SET PSODGETA=1
- DO C
- +11 KILL PSODGETA
- +12 ;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
- +13 if (($PIECE(^PSRX(RX,"STA"),"^")=4!($PIECE($GET(^PSRX(RX,"DRI")),"^",1)[1))&('$GET(RXF))&('$GET(RXP)))
- QUIT
- +14 ;
- LBL2 ;
- +1 IF $PIECE($GET(^PSRX(RX,3)),"^",6)
- IF '$GET(RXF)
- IF '$GET(RXP)
- DO ^PSOLLL9
- +2 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 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^VADPT6
- SET SSNPN=""
- +3 SET DAYS=$PIECE(^PSRX(RX,XTYPE,XXX,0),"^",10)
- End DoDot:1
- +4 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 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=""
- +5 SET DAYS=$PIECE(A,"^",8)
- End DoDot:1
- QUIT
- +6 IF '$DATA(^PSRX(RX,1,RXFL(RX),0))
- KILL RXFL(RX)
- QUIT
- +7 SET A=^PSRX(RX,1,RXFL(RX),0)
- +8 SET TECH=$SELECT($DATA(^VA(200,+$PIECE(A,"^",7),0)):$PIECE(^(0),"^"),1:"UNKNOWN")
- +9 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=""
- +10 SET DAYS=$PIECE(A,"^",10)
- +11 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