- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSORFL 2209 printed Feb 19, 2025@00:00:18 Page 2
- PSORFL ;BHAM ISC/CMD - THIS PROGRAM DETERMINES THE LAST FILL OF AN RX AND WHETHER ; 05/15/92 8:10
- +1 ;;7.0;OUTPATIENT PHARMACY;**19**;DEC 1997
- 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 if RFL
- SET RFL=$EXTRACT(RFL,4,5)_"/"_$EXTRACT(RFL,6,7)_"/"_$EXTRACT(RFL,2,3)
- if RFLL
- SET RFLL=$EXTRACT(RFLL,4,5)_"/"_$EXTRACT(RFLL,6,7)_"/"_($EXTRACT(RFLL,1,3)+1700)
- QUIT
- +1 ;
- 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