Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSORFL

PSORFL.m

Go to the documentation of this file.
PSORFL ;BHAM ISC/CMD - THIS PROGRAM DETERMINES THE LAST FILL OF AN RX AND WHETHER ; 05/15/92 8:10
 ;;7.0;OUTPATIENT PHARMACY;**19**;DEC 1997
MAIN D INIT,LAST
 I RFL1=0 D NEW G END
 S RFL=RFL1 D RFL G END
 ;
LAST S RFL1=0,RFL=$P(^PSRX(II,2),"^",2),RFLL=$P($G(^PSRX(II,3)),"^"),RFL=$S($O(^PSRX(II,1,0)):RFLL,1:RFL)
 ;I $P(^PSRX(II,"STA"),"^")'=3 F MJK=0:0 S MJK=$O(^PSRX(II,1,MJK)) Q:'MJK  S RFDATE=+^(MJK,0) S:RFL'>RFDATE RFL1=RFL,RFL=RFDATE
 S RFDATE=RFL D RFL K MJK Q
 ;
NEW S CDRUG=$P(^PSRX(II,0),"^",6),RFL=0
 F MJK=0:0 S MJK=$O(^PS(55,DFN,"P",MJK)) Q:'MJK  S MK=+^(MJK,0) I II'=MK,$D(^PSRX(MK,0)),$P(^(0),"^",6)=CDRUG D OLD
 I RFL=0 S RFL="N/A" Q
 D RFL Q
 ;
OLD S RFLX=$P(^PSRX(MK,0),"^",13) I $D(^(2)),$P(^(2),"^",2)]"" S RFLX=$P(^(2),"^",2)
 S:RFL'>RFLX RFL=RFLX,RFLMSG=LIT_$P(^PSRX(MK,0),"^")
 F MJK1=0:0 S MJK1=$O(^PSRX(MK,1,MJK1)) Q:'MJK1  S RFDATE=$P(^PSRX(MK,1,MJK1,0),"^") S:RFL'>RFDATE RFL=RFDATE,RFLMSG=LIT_$P(^PSRX(MK,0),"^")
 Q
 ;
INIT S RFLMSG="",LIT="*DRUG LAST FILLED UNDER RX# " Q
 ;
END K LIT,MK,MJK,MJK1,RFLX,RFDATE,CDRUG,II,RFL1 Q
 ;
RFL S:RFL RFL=$E(RFL,4,5)_"/"_$E(RFL,6,7)_"/"_$E(RFL,2,3) S:RFLL RFLL=$E(RFLL,4,5)_"/"_$E(RFLL,6,7)_"/"_($E(RFLL,1,3)+1700) Q
 ;
RFLDT S II=RX
 S (PSOFLRD,PSOLASTF,PSLASTRX)="" S PSOFLO=$P(^PSRX(II,2),"^",2) F PSOFLR=0:0 S PSOFLR=$O(^PSRX(II,1,PSOFLR)) Q:'PSOFLR  S PSOFLRD=+^PSRX(II,1,PSOFLR,0)
 I '$G(PSOFLRD) S PSOODRUG=$P(^PSRX(II,0),"^",6) F YYY=0:0 S YYY=$O(^PS(55,DFN,"P",YYY)) Q:'YYY  S PSOLDRX=+^(YYY,0) I II'=PSOLDRX,$P($G(^PSRX(PSOLDRX,0)),"^",6)=PSOODRUG S PSLASTRX=PSOLDRX D  S:PSPRERX>$G(PSOLASTF) PSOLASTF=PSPRERX
 .S PSPRERX=$P($G(^PSRX(PSLASTRX,2)),"^",2) I $O(^PSRX(PSLASTRX,1,0)) F RRR=0:0 S RRR=$O(^PSRX(PSLASTRX,1,RRR)) Q:'RRR  S PSPRERX=$P($G(^PSRX(PSLASTRX,1,RRR,0)),"^")
 I '$G(PSOFLRD),'$G(PSLASTRX) S PSOLASTF="N/A"
 I $G(PSOFLRD) F SSS=0:0 S SSS=$O(^PSRX(II,1,SSS)) Q:'SSS  S SSSNUM=SSS
 I $G(PSOFLRD) S SSSNUM=SSSNUM-1 S:SSSNUM=0 PSOLASTF=$P($G(^PSRX(II,2)),"^",2) S:SSSNUM>0 PSOLASTF=$P($G(^PSRX(II,1,SSSNUM,0)),"^")
 S:PSOLASTF'="N/A" PSOLASTF=$E(PSOLASTF,4,5)_"/"_$E(PSOLASTF,6,7)_"/"_($E(PSOLASTF,1,3)+1700)
 K PSOFLRD,PSOFLO,PSOFLR,PSOODRUG,PSOLDRX,PSLASTRX,PSPRERX,YYY,SSS,SSSNUM Q