PSORFL ;BHAM ISC/CMD - THIS PROGRAM DETERMINES THE LAST FILL OF AN RX AND WHETHER ;01-Feb-2011 09:21;SM
;;7.0;OUTPATIENT PHARMACY;**19,1010**;DEC 1997;Build 62
; Modified - IHS/MSC/PLS - 02/01/2011 - Line RFL
;
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 ;IHS/MSC/PLS - 02/01/2011
;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
I RFL,RFL'["/" S RFL=$E(RFL,4,5)_"/"_$E(RFL,6,7)_"/"_$E(RFL,2,3)
I RFLL,RFLL'["/" S 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
PSORFL ;BHAM ISC/CMD - THIS PROGRAM DETERMINES THE LAST FILL OF AN RX AND WHETHER ;01-Feb-2011 09:21;SM
+1 ;;7.0;OUTPATIENT PHARMACY;**19,1010**;DEC 1997;Build 62
+2 ; Modified - IHS/MSC/PLS - 02/01/2011 - Line RFL
+3 ;
MAIN DO INIT
DO LAST
+1 IF RFL1=0
DO NEW
GOTO END
+2 SET RFL=RFL1
DO RFL
GOTO END
+3 ;
LAST SET RFL1=0
SET RFL=$PIECE(^PSRX(II,2),"^",2)
SET RFLL=$PIECE($GET(^PSRX(II,3)),"^")
SET RFL=$SELECT($ORDER(^PSRX(II,1,0)):RFLL,1:RFL)
+1 ;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
+2 SET RFDATE=RFL
DO RFL
KILL MJK
QUIT
+3 ;
NEW SET CDRUG=$PIECE(^PSRX(II,0),"^",6)
SET RFL=0
+1 FOR MJK=0:0
SET MJK=$ORDER(^PS(55,DFN,"P",MJK))
IF 'MJK
QUIT
SET MK=+^(MJK,0)
IF II'=MK
IF $DATA(^PSRX(MK,0))
IF $PIECE(^(0),"^",6)=CDRUG
DO OLD
+2 IF RFL=0
SET RFL="N/A"
QUIT
+3 DO RFL
QUIT
+4 ;
OLD SET RFLX=$PIECE(^PSRX(MK,0),"^",13)
IF $DATA(^(2))
IF $PIECE(^(2),"^",2)]""
SET RFLX=$PIECE(^(2),"^",2)
+1 IF RFL'>RFLX
SET RFL=RFLX
SET RFLMSG=LIT_$PIECE(^PSRX(MK,0),"^")
+2 FOR MJK1=0:0
SET MJK1=$ORDER(^PSRX(MK,1,MJK1))
IF 'MJK1
QUIT
SET RFDATE=$PIECE(^PSRX(MK,1,MJK1,0),"^")
IF RFL'>RFDATE
SET RFL=RFDATE
SET RFLMSG=LIT_$PIECE(^PSRX(MK,0),"^")
+3 QUIT
+4 ;
INIT SET RFLMSG=""
SET LIT="*DRUG LAST FILLED UNDER RX# "
QUIT
+1 ;
END KILL LIT,MK,MJK,MJK1,RFLX,RFDATE,CDRUG,II,RFL1
QUIT
+1 ;
RFL ;IHS/MSC/PLS - 02/01/2011
+1 ;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
+2 IF RFL
IF RFL'["/"
SET RFL=$EXTRACT(RFL,4,5)_"/"_$EXTRACT(RFL,6,7)_"/"_$EXTRACT(RFL,2,3)
+3 IF RFLL
IF RFLL'["/"
SET RFLL=$EXTRACT(RFLL,4,5)_"/"_$EXTRACT(RFLL,6,7)_"/"_($EXTRACT(RFLL,1,3)+1700)
+4 QUIT
+5 ;
RFLDT SET II=RX
+1 SET (PSOFLRD,PSOLASTF,PSLASTRX)=""
SET PSOFLO=$PIECE(^PSRX(II,2),"^",2)
FOR PSOFLR=0:0
SET PSOFLR=$ORDER(^PSRX(II,1,PSOFLR))
IF 'PSOFLR
QUIT
SET PSOFLRD=+^PSRX(II,1,PSOFLR,0)
+2 IF '$GET(PSOFLRD)
SET PSOODRUG=$PIECE(^PSRX(II,0),"^",6)
FOR YYY=0:0
SET YYY=$ORDER(^PS(55,DFN,"P",YYY))
IF 'YYY
QUIT
SET PSOLDRX=+^(YYY,0)
IF II'=PSOLDRX
IF $PIECE($GET(^PSRX(PSOLDRX,0)),"^",6)=PSOODRUG
SET PSLASTRX=PSOLDRX
Begin DoDot:1
+3 SET PSPRERX=$PIECE($GET(^PSRX(PSLASTRX,2)),"^",2)
IF $ORDER(^PSRX(PSLASTRX,1,0))
FOR RRR=0:0
SET RRR=$ORDER(^PSRX(PSLASTRX,1,RRR))
IF 'RRR
QUIT
SET PSPRERX=$PIECE($GET(^PSRX(PSLASTRX,1,RRR,0)),"^")
End DoDot:1
IF PSPRERX>$GET(PSOLASTF)
SET PSOLASTF=PSPRERX
+4 IF '$GET(PSOFLRD)
IF '$GET(PSLASTRX)
SET PSOLASTF="N/A"
+5 IF $GET(PSOFLRD)
FOR SSS=0:0
SET SSS=$ORDER(^PSRX(II,1,SSS))
IF 'SSS
QUIT
SET SSSNUM=SSS
+6 IF $GET(PSOFLRD)
SET SSSNUM=SSSNUM-1
IF SSSNUM=0
SET PSOLASTF=$PIECE($GET(^PSRX(II,2)),"^",2)
IF SSSNUM>0
SET PSOLASTF=$PIECE($GET(^PSRX(II,1,SSSNUM,0)),"^")
+7 IF PSOLASTF'="N/A"
SET PSOLASTF=$EXTRACT(PSOLASTF,4,5)_"/"_$EXTRACT(PSOLASTF,6,7)_"/"_($EXTRACT(PSOLASTF,1,3)+1700)
+8 KILL PSOFLRD,PSOFLO,PSOFLR,PSOODRUG,PSOLDRX,PSLASTRX,PSPRERX,YYY,SSS,SSSNUM
QUIT
