source: FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLLLI.m@ 794

Last change on this file since 794 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 9.0 KB
Line 
1PSOLLLI ;BIR/JLC - LASER LABELS INITIALIZATION ;4/25/07 9:00am
2 ;;7.0;OUTPATIENT PHARMACY;**120,157,189,161,244,200,206**;DEC 1997;Build 39
3 ;
4 ;DBIAs PSDRUG-221, PS(55-2228, SC-10040, IBARX-125, PSXSRP-2201, %ZIS-3435, DPT-3097, ^TMP($J,"PSNPPIO"-3794
5 ;External reference to DRUG^PSSWRNA supported by DBIA 4449
6 ;
7 ;*244 remove test for partial fill when testing status > 11
8 ;
9DQ 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
10DQ1 I '$D(PPL) G HLEX
11 I $P($G(PSOPAR),"^",30)=2,'$G(PSOEXREP) G HLEX
12 K RXFLX S PSOCKHN=","_$G(PPL),PSRESOLV=+PPL D CHECK
13 S PSOINT=1 F PI=1:1 S RX=$P(PPL,",",PI) Q:RX="" D
14 . S RXY=$G(^PSRX(RX,0)) Q:RXY="" I PSOPDFN'=$P(RXY,"^",2),'PSOINT D TRAIL^PSOLLL1 S PSOPDFN=$P(RXY,"^",2)
15 . K RXP,REPRINT D C
16 I 'PSOINT D TRAIL^PSOLLL1
17HLEX 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
18 K SGY,OSGY,PS2,PSL,PSNP,INRX,RR,XTYPE,SSNP,SSNPN,PNM,ADDR,PSODBQ,PSOLASTF,PSRESOLV,PSOEXREP,PSOSXQ
19 K DATE,DR,DRUG,LINE,MW,PRTFL,VRPH,EXPDT,X2,DIFF,DAYS,PSZIP,PSOHZIP,PS55,PS55X
20 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
21 I '$G(PSOSUREP),'$G(PSOSUSPR) S ZTREQ="@"
22 Q
23C 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
24 U IO Q:'$D(^PSRX(RX,0)) S RXY=^(0),RX2=^(2),RXSTA=^("STA") K SGY,OSGY
25 S (SIGM,PFM,PMIM,L2,L3,L4,L5,FILLCONT,BOTTLBL)=0
26 K SIGF,PFF,PMIF S (SIGF,PFF,PMIF)=0 F I="DR","T" S (SIGF(I),PFF(I))=1
27 F I="A","B","I" S PMIF(I)=1
28 D NOW^%DTC S Y=$P(%,"."),PSOFNOW=% X ^DD("DD") S PSONOW=Y,Y=PSOFNOW X ^DD("DD") S PSONOWT=Y
29 S:$G(PSOBLALL) PSOBLRX=RX S:$D(RXRP(RX)) REPRINT=1 S:$D(RXPR(RX)) RXP=RXPR(RX)
30 I $G(PSOSUREP)!($G(PSOEXREP)) S REPRINT=1 I '$G(RXRP(RX)) S RXRP(RX)=1
31 S A=$P(RXSTA,"^") I A>11 D AL^PSOLBL("QT") K RXP,REPRINT Q ;*244
32 I A=3 D AL^PSOLBL("QT") K RXP,REPRINT Q
33 I $G(RXPR(RX)),'$D(^PSRX(RX,"P",RXP,0)) K RXP,REPRINT Q
34 I $P($G(RXFL(RX)),"^"),'$D(^PSRX(RX,1,$P($G(RXFL(RX)),"^"),0)) K RXP,REPRINT Q
35 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
36 I $G(RXRS(RX))!($G(PSOPULL)) S PSOSXQ=0 N DR,DA,DIE D I $G(PSOSXQ) K RXP,REPRINT Q
37 . S DA=$O(^PS(52.5,"B",RX,0)) Q:'DA
38 . S A=$P($G(^PS(52.5,DA,0)),"^",7) I A="" Q
39 . I A="Q" S DIE="^PS(52.5,",DR="3////P" D ^DIE Q
40 . K RXRS(RX) S PSOSXQ=1
41 I $G(PSRESOLV)=RX D ENLBL^PSOBSET K PSRESOLV
42 I $P(RXSTA,"^")'=4 D
43 . I $G(PSOSUSPR) D AREC^PSOSUTL
44 . I $G(PSOPULL)!($G(RXRS(RX))) D AREC1^PSOSUTL
45 . I $G(PSOSUREP) D AREC^PSOSUSRP
46 . I $G(PSXREP) D AREC^PSXSRP
47 S RXY=^PSRX(RX,0),RX2=^(2),RXSTA=^("STA")
48 K ^UTILITY("DIQ1",$J) S DA=$P($$SITE^VASITE(),"^")
49 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
50 S RXN=$P(RXY,"^"),DFN=+$P(RXY,"^",2),PSOLBLPS=+$P(RXY,"^",3),PSOLBLDR=+$P(RXY,"^",6)
51 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)="_"
52 S NURSE=$S($P($G(^DPT(DFN,"NHC")),"^")="Y":1,$P($G(^PS(55,DFN,40)),"^"):1,1:0)
53 S FDT=$P(RX2,"^",2),PS=$S($D(^PS(59,PSOSITE,0)):^(0),1:""),PS1=$S($D(^(1)):^(1),1:""),PSOSITE7=$P(^("IB"),"^")
54 S PS2=$P(PS,"^")_"^"_$P(PS,"^",6)
55 S EXPDT=$P(RX2,"^",6),EXDT=$S('EXPDT:"",1:$E(EXPDT,4,5)_"/"_$E(EXPDT,6,7)_"/"_($E(EXPDT,1,3)+1700))
56 S COPIES=$S($P($G(RXRP(RX)),"^",2):$P($G(RXRP(RX)),"^",2),$P(RXY,"^",18)]"":$P(RXY,"^",18),1:1)
57 K PSOCKHNX S PSOCKHL=$L(RX),PSOCKHN=$E($G(PSOCKHN),(PSOCKHL+2),999) D K PSOCKHNX,PSOCKHL,PSOCKHA
58 .S PSOCKHA=","_RX_","
59 .I PSOCKHN'[PSOCKHA Q
60 .S PSOCKHA=$E(PSOCKHA,1,($L(PSOCKHA)-1))
61 .S PSOCKHNX=$L(PSOCKHN,PSOCKHA)-1
62 .I +$G(PSOCKHNX)>0 D DOUB
63 I $O(^PSRX(RX,1,0)),$G(RXFL(RX))'=0 S $P(^PSRX(RX,3),"^",6)="" K ^PSRX(RX,"DAI"),^PSRX(RX,"DRI")
64 I '$G(RXP),'$O(^PSRX(RX,1,0)) S RXFL(RX)=0
65 I '$G(RXP) D OSET I '$O(^PSRX(RX,1,0))!($G(RXFL(RX))=0) G ORIG
66 I $O(^PSRX(RX,1,0)),'$G(RXP) D G STA
67 . I '$G(RXFL(RX)) S XTYPE=1 D REF
68 I $G(RXP) S XTYPE="P" D REF G STA
69ORIG S TECH=$P($G(^VA(200,+$P(RXY,"^",16),0)),"^"),PHYS=$S($D(^VA(200,+$P(RXY,"^",4),0)):$P(^(0),"^"),1:"UKN")
70 S DAYS=$P(RXY,"^",8),QTY=$P(RXY,"^",7)
71 D 6^VADPT,PID^VADPT6 S SSNPN=$G(VA("BID"))
72STA S STATE=$S($D(^DIC(5,+$P(PS,"^",8),0)):$P(^(0),"^",2),1:"UKN")
73 S DRUG=$$ZZ^PSOSUTL(RX),DEA=$P($G(^PSDRUG(+$P(RXY,"^",6),0)),"^",3),WARN=$P($G(^(0)),"^",8)
74 S WARN=$$DRUG^PSSWRNA(+$P(RXY,"^",6),+$P(RXY,"^",2))
75 S SIDE=$S($P($G(RXRP(RX)),"^",3):1,1:0)
76 I $G(^PSRX(RX,"P",+$G(RXP),0))]"" S RXPI=RXP D
77 .S RXP=^PSRX(RX,"P",RXP,0)
78 .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)
79 .S FDT=$P(RXP,"^")
80 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)
81 .I $G(RXFL(RX)),'$D(^PSRX(RX,1,RXFL(RX),0)) K RXFL(RX) Q
82 .S RXF=RXFL(RX) S:'$G(RXP) MW=$P($G(^PSRX(RX,1,RXF,0)),"^",2) I +^PSRX(RX,1,RXF,0)'<FDT S FDT=+^(0)
83 I MW="W",$G(^PSRX(RX,"MP"))]"" D
84 .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)
85 .K PSMP(PSI)
86 ;New mail codes for CMOP
87 S MAILCOM=""
88 S X=$G(^PS(55,DFN,0)),PSCAP=$P(X,"^",2),PS55=$P(X,"^",3),PS55X=$P(X,"^",5)
89 I PS55X]"",PS55>1,PS55X<DT S PS55=0
90 S:MW="M" MW=$S((PS55=1!(PS55=4)):"R",1:MW)
91 S MAILCOM=$P($G(^PS(59,PSOSITE,9)),"^")
92 S MW=$S(MW="M":"REGULAR",MW="R":"CERTIFIED",1:"WINDOW")
93 I $G(PSMP(1))="",$G(PS55)=2 S PSMP(1)=$G(SSNPN)
94 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
95 S (X,PSOFLAST)=$G(PSOLASTF) I X?1N.E D ^%DT X ^DD("DD") S PSOFLAST=Y
96 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
97 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"
98 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)
99 I $G(PSOCHAMP),$G(PSOTRAMT) S COPAYVAR="CHAMPUS" G LBL
100 I $G(RXP) S COPAYVAR="" G LBL
101 I $P($G(^PS(53,+$G(PSOLBLPS),0)),"^",7) D SNO G LBL
102 I DEA["I"!(DEA["S") D SNO G LBL
103 I $P(^PSRX(RX,"STA"),"^")>0,$P(^("STA"),"^")'=2,'$G(PSODBQ) D SNO G LBL
104 I $G(PSOLBLCP)="" D IBCP
105 N PSOQI S PSOQI=$G(^PSRX(RX,"IBQ"))
106 I $G(PSOLBLCP)=0 D SNO G LBL
107 I $G(PSOLBLCP)=1 I $P(PSOQI,"^",2)!($P(PSOQI,"^",3))!($P(PSOQI,"^",4))!($P(PSOQI,"^",5))!($P(PSOQI,"^",6))!($P(PSOQI,"^",7)) D SNO G LBL
108 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)) D SNO G LBL
109 I $G(PSOLBLCP)=2,'$P($G(^PSRX(RX,"IB")),"^") D SNO G LBL
110 S PSOCPN=$P(RXY,"^",2),INRX=$P(RXY,"^")
111 I $G(^TMP($J,"PSOCP",PSOCPN))="" S ^(PSOCPN)=PSOCPN
112 S ^TMP($J,"PSOCP",PSOCPN,INRX)=INRX_"^"_$$ZZ^PSOSUTL(RX)_"^"_+$G(DAYS),COPAYVAR="COPAY" K ZDRUG
113LBL I $G(PSOIO("LLI"))]"" X PSOIO("LLI")
114 I $P(RXSTA,"^")=4 D ^PSOLLL8 Q ;for a critical interaction entered by a tech - don't allow a label to be printed
115 I $D(^PSRX(RX,"DRI")),'$G(RXF),'$G(RXP) D ^PSOLLL8
116 I $P($G(^PSRX(RX,3)),"^",6),'$G(RXF),'$G(RXP) D ^PSOLLL9
117 S PSOINT=0 G ^PSOLLL1
118REF F XXX=0:0 S XXX=$O(^PSRX(RX,XTYPE,XXX)) Q:+XXX'>0 D
119 .S TECH=$S($D(^VA(200,+$P(^PSRX(RX,XTYPE,XXX,0),"^",7),0)):$P(^(0),"^"),1:"UNKNOWN")
120 .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=$G(VA("BID"))
121 .S DAYS=$P(^PSRX(RX,XTYPE,XXX,0),"^",10)
122 Q
123CHECK S PSDFNFLG=0,PSOZERO=$P(PPL,","),PSOPDFN=$P(^PSRX(PSOZERO,0),"^",2)
124 Q
125OSET ;
126 N A
127 I $G(RXFL(RX))']""!($G(RXFL(RX))=0) D Q
128 .S A=^PSRX(RX,0)
129 .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=$G(VA("BID"))
130 .S DAYS=$P(A,"^",8)
131 I '$D(^PSRX(RX,1,RXFL(RX),0)) K RXFL(RX) Q
132 S A=^PSRX(RX,1,RXFL(RX),0)
133 S TECH=$S($D(^VA(200,+$P(A,"^",7),0)):$P(^(0),"^"),1:"UNKNOWN")
134 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=$G(VA("BID"))
135 S DAYS=$P(A,"^",10)
136 Q
137DOUB ;
138 Q:'$D(RXFL(RX))
139 I +$G(RXFL(RX))-PSOCKHNX<0 Q
140 S RXFLX(RX)=$G(RXFL(RX))
141 S RXFL(RX)=$G(RXFL(RX))-PSOCKHNX
142 Q
143IBCP ;
144 N X,Y,PSOJJ,PSOLL
145 S PSOLBLCP=""
146 S X=$P($G(^PS(59,+$G(PSOSITE),"IB")),"^")_"^"_$G(DFN) D XTYPE^IBARX
147 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
148 I '$G(PSOLBLCP) S PSOLBLCP=0
149 Q
150SNO ;
151 S COPAYVAR="NO COPAY"
152 Q
Note: See TracBrowser for help on using the repository browser.