- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLLLI.m
r613 r623 1 PSOLLLI ;BIR/JLC - LASER LABELS INITIALIZATION ;4/25/07 9:00am2 ;;7.0;OUTPATIENT PHARMACY;**120,157,189,161,244,200,206,225**;DEC 1997;Build 29 3 4 5 6 7 8 9 DQ 10 DQ1 11 12 13 14 15 16 17 HLEX 18 19 20 21 22 23 C 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 ORIG 70 71 72 STA 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 I PS55X]"",PS55>1,PS55X<DT S PS55=0 90 91 92 93 94 95 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=097 98 99 100 101 102 103 104 105 106 107 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 LBL108 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 LBL109 110 111 112 113 LBL 114 115 116 117 118 REF 119 120 121 122 123 CHECK 124 125 OSET 126 127 128 129 130 131 132 133 134 135 136 137 DOUB 138 139 140 141 142 143 IBCP 144 145 146 147 148 149 150 SNO 151 152 1 PSOLLLI ;BIR/JLC - LASER LABELS INITIALIZATION ;10 Oct 2006 4:56 PM 2 ;;7.0;OUTPATIENT PHARMACY;**120,157,189,161,244,200**;DEC 1997;Build 7 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 ; 9 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 10 DQ1 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 17 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 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 23 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 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 69 ORIG 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")) 72 STA 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=1 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["A"&(DEA'["B"))!(DEA["W") 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 113 LBL 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 118 REF 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 123 CHECK S PSDFNFLG=0,PSOZERO=$P(PPL,","),PSOPDFN=$P(^PSRX(PSOZERO,0),"^",2) 124 Q 125 OSET ; 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 137 DOUB ; 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 143 IBCP ; 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 150 SNO ; 151 S COPAYVAR="NO COPAY" 152 Q
Note:
See TracChangeset
for help on using the changeset viewer.
