- PSOREF0 ;IHS/JCM - REFILL CON'T ;21-Nov-2010 19:44;SM
- ;;7.0;OUTPATIENT PHARMACY;**14,152,180,1003,1005,1009,186,204,306,1014**;DEC 1997;Build 62
- ;External reference to ^PSDRUG supported by DBIA 221
- ;
- ;PSO*186 add check for DEA Special handling field refill restrictions
- ; Modified - IHS/CIA/PLS - 01/06/04 - Line PROCESS+5 and PROCESS+8
- ; 08/30/05 - Line PROCESS+7
- ; 01/22/07 - Line PROCESS+6
- ; 01/25/07 - Line PROCESS+10 - Added XFROM conditional
- ; 11/20/10 - Line CHECK+3
- PROCESS ;
- K PSODF S PSOREF("RX0")=^PSRX(PSOREF("IRXN"),0),PSOREF("RX2")=^(2),PSOREF("RX3")=^(3),PSOREF("STA")=+$G(^("STA")),PSOREF("SIG")=$P($G(^("SIG")),"^"),PSOREF("PSODFN")=$P(PSOREF("RX0"),"^",2)
- S PSOREF("DAYS SUPPLY")=$P(PSOREF("RX0"),"^",8)
- I $D(PSORX("BAR CODE")),PSODFN'=PSOREF("PSODFN") D NEWPT
- W !,"Now refilling Rx# ",$P(PSOREF("RX0"),"^")_" Drug: "_$P(^PSDRUG($P(PSOREF("RX0"),"^",6),0),"^")
- K ZD(PSOREF("IRXN")) ;*306
- ; IHS/MSC/PLS - 01/22/07 - Added next line - Patch 1005
- W !,"Patient: "_$$GET1^DIQ(2,PSODFN,.01)_" HRN: "_$$HRN^AUPNPAT(PSODFN,DUZ(2))_" LFDT: "_$$FMTE^XLFDT(+PSOREF("RX3"),"5Z")
- D PRINT^APSQLAB ; IHS/CIA/PLS - 01/06/04 - Display appropriate lab results
- S PSOREF("DFLG")=0 D DSPLY G:PSOREF("DFLG") PROCESSX
- ;IHS/CIA/PLS - 08/30/205 - Added logic to populate IHS fields
- ;IHS/MSC/PLS - 01/25/2007 - Added XFROM condition for AudioCare processing
- D:$G(XFROM)="BATCH"!('$D(PSOREF("AWP"))) IHSSET^PSOREF1
- D CHECK G:$G(PSODF) PROCESS G:PSOREF("DFLG") PROCESSX D EN^PSOR52(.PSOREF)
- ; IHS/CIA/PLS - 02/10/04 - Paperless refill
- ; 04/29/05 - PCC logic moved to APSP namespace
- ;S X="CIAZPRX1" X ^%ZOSF("TEST") I $T D EN^CIAZPRX1(PSOREF("PSODFN"),PSOREF("IRXN"))
- D EN^APSPPCC1(PSOREF("PSODFN"),PSOREF("IRXN"))
- S:$G(PSOREF("MAIL/WINDOW"))["W" BINGRTE="W",BINGCRT=1
- PROCESSX D:$G(PSOREF("OLD FILL DATE"))]"" SUSDATEK^PSOUTIL(.PSOREF)
- Q
- DSPLY ;W !!,$P(PSOREF("RX0"),"^"),?12," ",$P(^PSDRUG($P(PSOREF("RX0"),"^",6),0),"^"),?45," SIG: "_PSOREF("SIG"),?60," QTY: ",$P(PSOREF("RX0"),"^",7)
- K FSIG,BSIG I $P($G(^PSRX(PSOREF("IRXN"),"SIG")),"^",2) D FSIG^PSOUTLA("R",PSOREF("IRXN"),54) F PSREV=1:1 Q:'$D(FSIG(PSREV)) S BSIG(PSREV)=FSIG(PSREV)
- K FSIG,PSREV I '$P($G(^PSRX(PSOREF("IRXN"),"SIG")),"^",2) D EN2^PSOUTLA1(PSOREF("IRXN"),54)
- W !!,"Qty: ",$P(PSOREF("RX0"),"^",7),?19,"Sig: ",$G(BSIG(1))
- I $O(BSIG(1)) F PSREV=1:0 S PSREV=$O(BSIG(PSREV)) Q:'PSREV W !?24,$G(BSIG(PSREV))
- K BSIG,PSREV
- DSPLYX Q
- CHECK ;
- I '$P(PSOPAR,"^",11),$G(^PSDRUG($P(PSOREF("RX0"),"^",6),"I"))]"",DT>$G(^("I")) D G CKQ
- .W $C(7),!!," *** Drug is inactive for Rx # "_$P(PSOREF("RX0"),"^")_" cannot be refilled ***",!
- I '$$SCREEN^APSPMULT(+$P(PSOREF("RX0"),"^",6),,1) W $C(7),!!,"** Drug is not selectable for Rx # "_$P(PSOREF("RX0"),"^")_" cannot be refilled ***",! G CKQ ;IHS/MSC/JDS - 11/20/10
- I '$D(PSORX("BAR CODE")),PSOREF("PSODFN")'=PSODFN W !!,?5,$C(7),"Can't refill Rx # "_$P(PSOREF("RX0"),"^")_", it is not for this patient." G CKQ
- S (PSOX,PSOY,STA)=""
- I $G(PSOSD) F S STA=$O(PSOSD(STA)) Q:STA="" F S PSOX=$O(PSOSD(STA,PSOX)) Q:PSOX']""!(PSOREF("DFLG")) I PSOREF("IRXN")=+PSOSD(STA,PSOX) S PSOY=PSOSD(STA,PSOX) I $P(PSOY,"^",4)]"" D
- . S PSOREF("DFLG")=1 W:'$G(PSOERR) !,$C(7),"Cannot refill Rx # "_$P(PSOREF("RX0"),"^") S PSOREA=$P(PSOY,"^",4),PSOSTAT=PSOREF("STA")
- . D STATUS^PSOUTIL(PSOREA,PSOSTAT) K PSOREA,PSOSTAT
- . Q
- I PSOY="" W !,$C(7),"Cannot refill, Rx is discontinued or expired. Later Rx may exist.",! D I $G(PSODF) Q
- .D LOOK^PSOREF2 I $G(PSODF) Q
- .S PSOREF("DFLG")=1
- K PSOX,PSOY G:PSOREF("DFLG") CHECKX
- I $O(^PS(52.5,"B",PSOREF("IRXN"),0)),'$G(^PS(52.5,+$O(^PS(52.5,"B",PSOREF("IRXN"),0)),"P")) W !,$C(7),"Rx is in suspense and cannot be refilled" S PSOREF("DFLG")=1 G CHECKX
- ;
- S PSOREF("RXSTATUS")=PSOREF("STA")
- I PSOREF("RXSTATUS"),PSOREF("RXSTATUS")'=6 D G CHECKX
- . S PSOY=";"_PSOREF("RXSTATUS"),PSOX=$P(^DD(52,100,0),"^",3),PSOY=$F(PSOX,PSOY),PSOY=$P($E(PSOX,PSOY,999),";",1)
- . W !,$C(7),"Rx is in "_PSOY_" status, cannot be refilled" S PSOREF("DFLG")=1
- D CHKDIV G:PSOREF("DFLG") CHECKX
- D NUMBER I PSOREF("NUMBER")>$P(PSOREF("RX0"),"^",9) W !?5,"Can't refill, no refills remaining." S PSOREF("DFLG")=1 G CHECKX
- ;
- ;PSO*7*186 check DEA, SPEC HNDLG field, in case changed, and apply
- N PSODRG,PSODEA,PSODAY
- S PSODRG=$G(^PSDRUG($P(PSOREF("RX0"),U,6),0)),PSODEA=$P(PSODRG,U,3)
- S PSODAY=$P(PSOREF("RX0"),U,8)
- I $$DEACHK^PSOUTLA1(PSOREF("IRXN"),PSODEA,PSODAY) D G CHECKX
- . W $C(7),!!,"This drug has been changed, No refills allowed",!
- . S PSOREF("DFLG")=1
- ;
- D DATES
- CHECKX Q
- CKQ ;
- S PSOREF("DFLG")=1 D PAUSE^VALM1 G CHECKX
- Q
- ;
- CHKDIV G:$P(PSOREF("RX2"),"^",9)=+PSOSITE CHKDIVX
- W !?5,$C(7),"RX # ",$P(PSOREF("RX0"),"^")," is for (",$P(^PS(59,$P(PSOREF("RX2"),"^",9),0),"^"),") division."
- I '$P($G(PSOSYS),"^",2) S (PSOREF("DFLG"),PSOMHV)=1 W !,"********* Not Refilled *********" G CHKDIVX
- D:$P($G(PSOSYS),"^",3) DIR
- CHKDIVX Q
- ;
- NUMBER K PSOX,PSOY S PSOREF("# OF REFILLS")=0
- I $G(^PSRX(PSOREF("IRXN"),1,0))]"" F PSOX=0:0 S PSOX=$O(^PSRX(PSOREF("IRXN"),1,PSOX)) Q:'PSOX S PSOREF("# OF REFILLS")=PSOX
- S PSOREF("NUMBER")=PSOREF("# OF REFILLS")+1
- Q
- ;
- DATES S PSOREF("STOP DATE")=$P(PSOREF("RX2"),"^",6) D NEXT^PSOUTIL(.PSOREF)
- D:$G(PSOBBC("QFLG"))&($P(PSOPAR,"^",6)) EDATE Q:$G(PSOREF("DFLG"))
- S PSOREF("FILL DATE")=$S($G(PSOREF("FILL DATE")):PSOREF("FILL DATE"),1:DT)
- I $P(PSOPAR,"^",6),PSOREF("FILL DATE")<$P(PSOREF("RX3"),"^",2) D SUSDATE^PSOUTIL(.PSOREF)
- ;
- I PSOREF("FILL DATE")>PSOREF("STOP DATE") D
- . W !!?5,$C(7),"Can't refill, Refill Date ",$E(PSOREF("FILL DATE"),4,5),"/",$E(PSOREF("FILL DATE"),6,7),"/"
- . W $E(PSOREF("FILL DATE"),2,3)," is past Expiration Date ",$E(PSOREF("STOP DATE"),4,5),"/",$E(PSOREF("STOP DATE"),6,7),"/"
- . W $E(PSOREF("STOP DATE"),2,3) S PSOREF("DFLG")=1
- EDATE S PSOREF("LAST REFILL DATE")=$P(PSOREF("RX3"),"^",1)
- I PSOREF("LAST REFILL DATE"),PSOREF("FILL DATE")=PSOREF("LAST REFILL DATE") D G DATESX
- . W !?5,"Can't refill, Fill Date already exists for ",$E(PSOREF("FILL DATE"),4,5),"/",$E(PSOREF("FILL DATE"),6,7),"/",$E(PSOREF("FILL DATE"),2,3)
- . S PSOREF("DFLG")=1
- I PSOREF("LAST REFILL DATE"),PSOREF("FILL DATE")<PSOREF("LAST REFILL DATE") D G DATESX
- . W !?5,"Can't refill, later Refill Date already exists for ",$E(PSOREF("LAST REFILL DATE"),4,5),"/",$E(PSOREF("LAST REFILL DATE"),6,7),"/",$E(PSOREF("LAST REFILL DATE"),2,3)
- . S PSOREF("DFLG")=1
- I '$P(PSOPAR,"^",6),'$D(PSOREF("EAOK")),$P(PSOREF("RX3"),"^",2)>PSOREF("FILL DATE") D
- . S PSOX1=(PSOREF("NUMBER")+1)*PSOREF("DAYS SUPPLY")-10
- . W !?5,$C(7),"LESS THAN ",PSOX1," DAYS FOR ",PSOREF("NUMBER")+1," FILLS",! D DIR K PSOX1
- I '$P(PSOPAR,"^",6),$G(PSOREF("EAOK"))=0,$P(PSOREF("RX3"),"^",2)>PSOREF("FILL DATE") D
- . S Y=$P(PSOREF("RX3"),"^",2) D DD^%DT W !!,$C(7),"Cannot be refilled until "_Y_"." S (PSOREF("DFLG"),PSOMHV)=1 K Y
- DATESX Q
- DIR K DIR,X,Y S DIR(0)="Y",DIR("A")="Continue ",DIR("B")="N",DIR("?")="Answer YES to Refill, NO to bypass"
- D ^DIR K DIR S:$D(DIRUT)!('Y) (PSOREF("DFLG"),PSOMHV)=1 K DIRUT,DTOUT,DUOUT,X,Y
- Q
- NEWPT S PSOQFLG=0,(DFN,PSODFN)=PSOREF("PSODFN") D ^PSOPTPST I PSOQFLG S PSOREF("DFLG")=1,PSOQFLG=0 G NEWPTX
- D PROFILE^PSOREF1
- NEWPTX Q
- ;
- EN(PSOREF) ; Entry Point for Batch Barcode Option
- D PROCESS K DRUG,PSODF
- Q
- PSOREF0 ;IHS/JCM - REFILL CON'T ;21-Nov-2010 19:44;SM
- +1 ;;7.0;OUTPATIENT PHARMACY;**14,152,180,1003,1005,1009,186,204,306,1014**;DEC 1997;Build 62
- +2 ;External reference to ^PSDRUG supported by DBIA 221
- +3 ;
- +4 ;PSO*186 add check for DEA Special handling field refill restrictions
- +5 ; Modified - IHS/CIA/PLS - 01/06/04 - Line PROCESS+5 and PROCESS+8
- +6 ; 08/30/05 - Line PROCESS+7
- +7 ; 01/22/07 - Line PROCESS+6
- +8 ; 01/25/07 - Line PROCESS+10 - Added XFROM conditional
- +9 ; 11/20/10 - Line CHECK+3
- PROCESS ;
- +1 KILL PSODF
- SET PSOREF("RX0")=^PSRX(PSOREF("IRXN"),0)
- SET PSOREF("RX2")=^(2)
- SET PSOREF("RX3")=^(3)
- SET PSOREF("STA")=+$GET(^("STA"))
- SET PSOREF("SIG")=$PIECE($GET(^("SIG")),"^")
- SET PSOREF("PSODFN")=$PIECE(PSOREF("RX0"),"^",2)
- +2 SET PSOREF("DAYS SUPPLY")=$PIECE(PSOREF("RX0"),"^",8)
- +3 IF $DATA(PSORX("BAR CODE"))
- IF PSODFN'=PSOREF("PSODFN")
- DO NEWPT
- +4 WRITE !,"Now refilling Rx# ",$PIECE(PSOREF("RX0"),"^")_" Drug: "_$PIECE(^PSDRUG($PIECE(PSOREF("RX0"),"^",6),0),"^")
- +5 ;*306
- KILL ZD(PSOREF("IRXN"))
- +6 ; IHS/MSC/PLS - 01/22/07 - Added next line - Patch 1005
- +7 WRITE !,"Patient: "_$$GET1^DIQ(2,PSODFN,.01)_" HRN: "_$$HRN^AUPNPAT(PSODFN,DUZ(2))_" LFDT: "_$$FMTE^XLFDT(+PSOREF("RX3"),"5Z")
- +8 ; IHS/CIA/PLS - 01/06/04 - Display appropriate lab results
- DO PRINT^APSQLAB
- +9 SET PSOREF("DFLG")=0
- DO DSPLY
- IF PSOREF("DFLG")
- GOTO PROCESSX
- +10 ;IHS/CIA/PLS - 08/30/205 - Added logic to populate IHS fields
- +11 ;IHS/MSC/PLS - 01/25/2007 - Added XFROM condition for AudioCare processing
- +12 IF $GET(XFROM)="BATCH"!('$DATA(PSOREF("AWP")))
- DO IHSSET^PSOREF1
- +13 DO CHECK
- IF $GET(PSODF)
- GOTO PROCESS
- IF PSOREF("DFLG")
- GOTO PROCESSX
- DO EN^PSOR52(.PSOREF)
- +14 ; IHS/CIA/PLS - 02/10/04 - Paperless refill
- +15 ; 04/29/05 - PCC logic moved to APSP namespace
- +16 ;S X="CIAZPRX1" X ^%ZOSF("TEST") I $T D EN^CIAZPRX1(PSOREF("PSODFN"),PSOREF("IRXN"))
- +17 DO EN^APSPPCC1(PSOREF("PSODFN"),PSOREF("IRXN"))
- +18 IF $GET(PSOREF("MAIL/WINDOW"))["W"
- SET BINGRTE="W"
- SET BINGCRT=1
- PROCESSX IF $GET(PSOREF("OLD FILL DATE"))]""
- DO SUSDATEK^PSOUTIL(.PSOREF)
- +1 QUIT
- DSPLY ;W !!,$P(PSOREF("RX0"),"^"),?12," ",$P(^PSDRUG($P(PSOREF("RX0"),"^",6),0),"^"),?45," SIG: "_PSOREF("SIG"),?60," QTY: ",$P(PSOREF("RX0"),"^",7)
- +1 KILL FSIG,BSIG
- IF $PIECE($GET(^PSRX(PSOREF("IRXN"),"SIG")),"^",2)
- DO FSIG^PSOUTLA("R",PSOREF("IRXN"),54)
- FOR PSREV=1:1
- IF '$DATA(FSIG(PSREV))
- QUIT
- SET BSIG(PSREV)=FSIG(PSREV)
- +2 KILL FSIG,PSREV
- IF '$PIECE($GET(^PSRX(PSOREF("IRXN"),"SIG")),"^",2)
- DO EN2^PSOUTLA1(PSOREF("IRXN"),54)
- +3 WRITE !!,"Qty: ",$PIECE(PSOREF("RX0"),"^",7),?19,"Sig: ",$GET(BSIG(1))
- +4 IF $ORDER(BSIG(1))
- FOR PSREV=1:0
- SET PSREV=$ORDER(BSIG(PSREV))
- IF 'PSREV
- QUIT
- WRITE !?24,$GET(BSIG(PSREV))
- +5 KILL BSIG,PSREV
- DSPLYX QUIT
- CHECK ;
- +1 IF '$PIECE(PSOPAR,"^",11)
- IF $GET(^PSDRUG($PIECE(PSOREF("RX0"),"^",6),"I"))]""
- IF DT>$GET(^("I"))
- Begin DoDot:1
- +2 WRITE $CHAR(7),!!," *** Drug is inactive for Rx # "_$PIECE(PSOREF("RX0"),"^")_" cannot be refilled ***",!
- End DoDot:1
- GOTO CKQ
- +3 ;IHS/MSC/JDS - 11/20/10
- IF '$$SCREEN^APSPMULT(+$PIECE(PSOREF("RX0"),"^",6),,1)
- WRITE $CHAR(7),!!,"** Drug is not selectable for Rx # "_$PIECE(PSOREF("RX0"),"^")_" cannot be refilled ***",!
- GOTO CKQ
- +4 IF '$DATA(PSORX("BAR CODE"))
- IF PSOREF("PSODFN")'=PSODFN
- WRITE !!,?5,$CHAR(7),"Can't refill Rx # "_$PIECE(PSOREF("RX0"),"^")_", it is not for this patient."
- GOTO CKQ
- +5 SET (PSOX,PSOY,STA)=""
- +6 IF $GET(PSOSD)
- FOR
- SET STA=$ORDER(PSOSD(STA))
- IF STA=""
- QUIT
- FOR
- SET PSOX=$ORDER(PSOSD(STA,PSOX))
- IF PSOX']""!(PSOREF("DFLG"))
- QUIT
- IF PSOREF("IRXN")=+PSOSD(STA,PSOX)
- SET PSOY=PSOSD(STA,PSOX)
- IF $PIECE(PSOY,"^",4)]""
- Begin DoDot:1
- +7 SET PSOREF("DFLG")=1
- IF '$GET(PSOERR)
- WRITE !,$CHAR(7),"Cannot refill Rx # "_$PIECE(PSOREF("RX0"),"^")
- SET PSOREA=$PIECE(PSOY,"^",4)
- SET PSOSTAT=PSOREF("STA")
- +8 DO STATUS^PSOUTIL(PSOREA,PSOSTAT)
- KILL PSOREA,PSOSTAT
- +9 QUIT
- End DoDot:1
- +10 IF PSOY=""
- WRITE !,$CHAR(7),"Cannot refill, Rx is discontinued or expired. Later Rx may exist.",!
- Begin DoDot:1
- +11 DO LOOK^PSOREF2
- IF $GET(PSODF)
- QUIT
- +12 SET PSOREF("DFLG")=1
- End DoDot:1
- IF $GET(PSODF)
- QUIT
- +13 KILL PSOX,PSOY
- IF PSOREF("DFLG")
- GOTO CHECKX
- +14 IF $ORDER(^PS(52.5,"B",PSOREF("IRXN"),0))
- IF '$GET(^PS(52.5,+$ORDER(^PS(52.5,"B",PSOREF("IRXN"),0)),"P"))
- WRITE !,$CHAR(7),"Rx is in suspense and cannot be refilled"
- SET PSOREF("DFLG")=1
- GOTO CHECKX
- +15 ;
- +16 SET PSOREF("RXSTATUS")=PSOREF("STA")
- +17 IF PSOREF("RXSTATUS")
- IF PSOREF("RXSTATUS")'=6
- Begin DoDot:1
- +18 SET PSOY=";"_PSOREF("RXSTATUS")
- SET PSOX=$PIECE(^DD(52,100,0),"^",3)
- SET PSOY=$FIND(PSOX,PSOY)
- SET PSOY=$PIECE($EXTRACT(PSOX,PSOY,999),";",1)
- +19 WRITE !,$CHAR(7),"Rx is in "_PSOY_" status, cannot be refilled"
- SET PSOREF("DFLG")=1
- End DoDot:1
- GOTO CHECKX
- +20 DO CHKDIV
- IF PSOREF("DFLG")
- GOTO CHECKX
- +21 DO NUMBER
- IF PSOREF("NUMBER")>$PIECE(PSOREF("RX0"),"^",9)
- WRITE !?5,"Can't refill, no refills remaining."
- SET PSOREF("DFLG")=1
- GOTO CHECKX
- +22 ;
- +23 ;PSO*7*186 check DEA, SPEC HNDLG field, in case changed, and apply
- +24 NEW PSODRG,PSODEA,PSODAY
- +25 SET PSODRG=$GET(^PSDRUG($PIECE(PSOREF("RX0"),U,6),0))
- SET PSODEA=$PIECE(PSODRG,U,3)
- +26 SET PSODAY=$PIECE(PSOREF("RX0"),U,8)
- +27 IF $$DEACHK^PSOUTLA1(PSOREF("IRXN"),PSODEA,PSODAY)
- Begin DoDot:1
- +28 WRITE $CHAR(7),!!,"This drug has been changed, No refills allowed",!
- +29 SET PSOREF("DFLG")=1
- End DoDot:1
- GOTO CHECKX
- +30 ;
- +31 DO DATES
- CHECKX QUIT
- CKQ ;
- +1 SET PSOREF("DFLG")=1
- DO PAUSE^VALM1
- GOTO CHECKX
- +2 QUIT
- +3 ;
- CHKDIV IF $PIECE(PSOREF("RX2"),"^",9)=+PSOSITE
- GOTO CHKDIVX
- +1 WRITE !?5,$CHAR(7),"RX # ",$PIECE(PSOREF("RX0"),"^")," is for (",$PIECE(^PS(59,$PIECE(PSOREF("RX2"),"^",9),0),"^"),") division."
- +2 IF '$PIECE($GET(PSOSYS),"^",2)
- SET (PSOREF("DFLG"),PSOMHV)=1
- WRITE !,"********* Not Refilled *********"
- GOTO CHKDIVX
- +3 IF $PIECE($GET(PSOSYS),"^",3)
- DO DIR
- CHKDIVX QUIT
- +1 ;
- NUMBER KILL PSOX,PSOY
- SET PSOREF("# OF REFILLS")=0
- +1 IF $GET(^PSRX(PSOREF("IRXN"),1,0))]""
- FOR PSOX=0:0
- SET PSOX=$ORDER(^PSRX(PSOREF("IRXN"),1,PSOX))
- IF 'PSOX
- QUIT
- SET PSOREF("# OF REFILLS")=PSOX
- +2 SET PSOREF("NUMBER")=PSOREF("# OF REFILLS")+1
- +3 QUIT
- +4 ;
- DATES SET PSOREF("STOP DATE")=$PIECE(PSOREF("RX2"),"^",6)
- DO NEXT^PSOUTIL(.PSOREF)
- +1 IF $GET(PSOBBC("QFLG"))&($PIECE(PSOPAR,"^",6))
- DO EDATE
- IF $GET(PSOREF("DFLG"))
- QUIT
- +2 SET PSOREF("FILL DATE")=$SELECT($GET(PSOREF("FILL DATE")):PSOREF("FILL DATE"),1:DT)
- +3 IF $PIECE(PSOPAR,"^",6)
- IF PSOREF("FILL DATE")<$PIECE(PSOREF("RX3"),"^",2)
- DO SUSDATE^PSOUTIL(.PSOREF)
- +4 ;
- +5 IF PSOREF("FILL DATE")>PSOREF("STOP DATE")
- Begin DoDot:1
- +6 WRITE !!?5,$CHAR(7),"Can't refill, Refill Date ",$EXTRACT(PSOREF("FILL DATE"),4,5),"/",$EXTRACT(PSOREF("FILL DATE"),6,7),"/"
- +7 WRITE $EXTRACT(PSOREF("FILL DATE"),2,3)," is past Expiration Date ",$EXTRACT(PSOREF("STOP DATE"),4,5),"/",$EXTRACT(PSOREF("STOP DATE"),6,7),"/"
- +8 WRITE $EXTRACT(PSOREF("STOP DATE"),2,3)
- SET PSOREF("DFLG")=1
- End DoDot:1
- EDATE SET PSOREF("LAST REFILL DATE")=$PIECE(PSOREF("RX3"),"^",1)
- +1 IF PSOREF("LAST REFILL DATE")
- IF PSOREF("FILL DATE")=PSOREF("LAST REFILL DATE")
- Begin DoDot:1
- +2 WRITE !?5,"Can't refill, Fill Date already exists for ",$EXTRACT(PSOREF("FILL DATE"),4,5),"/",$EXTRACT(PSOREF("FILL DATE"),6,7),"/",$EXTRACT(PSOREF("FILL DATE"),2,3)
- +3 SET PSOREF("DFLG")=1
- End DoDot:1
- GOTO DATESX
- +4 IF PSOREF("LAST REFILL DATE")
- IF PSOREF("FILL DATE")<PSOREF("LAST REFILL DATE")
- Begin DoDot:1
- +5 WRITE !?5,"Can't refill, later Refill Date already exists for ",$EXTRACT(PSOREF("LAST REFILL DATE"),4,5),"/",$EXTRACT(PSOREF("LAST REFILL DATE"),6,7),"/",$EXTRACT(PSOREF("LAST REFILL DATE"),2,3)
- +6 SET PSOREF("DFLG")=1
- End DoDot:1
- GOTO DATESX
- +7 IF '$PIECE(PSOPAR,"^",6)
- IF '$DATA(PSOREF("EAOK"))
- IF $PIECE(PSOREF("RX3"),"^",2)>PSOREF("FILL DATE")
- Begin DoDot:1
- +8 SET PSOX1=(PSOREF("NUMBER")+1)*PSOREF("DAYS SUPPLY")-10
- +9 WRITE !?5,$CHAR(7),"LESS THAN ",PSOX1," DAYS FOR ",PSOREF("NUMBER")+1," FILLS",!
- DO DIR
- KILL PSOX1
- End DoDot:1
- +10 IF '$PIECE(PSOPAR,"^",6)
- IF $GET(PSOREF("EAOK"))=0
- IF $PIECE(PSOREF("RX3"),"^",2)>PSOREF("FILL DATE")
- Begin DoDot:1
- +11 SET Y=$PIECE(PSOREF("RX3"),"^",2)
- DO DD^%DT
- WRITE !!,$CHAR(7),"Cannot be refilled until "_Y_"."
- SET (PSOREF("DFLG"),PSOMHV)=1
- KILL Y
- End DoDot:1
- DATESX QUIT
- DIR KILL DIR,X,Y
- SET DIR(0)="Y"
- SET DIR("A")="Continue "
- SET DIR("B")="N"
- SET DIR("?")="Answer YES to Refill, NO to bypass"
- +1 DO ^DIR
- KILL DIR
- IF $DATA(DIRUT)!('Y)
- SET (PSOREF("DFLG"),PSOMHV)=1
- KILL DIRUT,DTOUT,DUOUT,X,Y
- +2 QUIT
- NEWPT SET PSOQFLG=0
- SET (DFN,PSODFN)=PSOREF("PSODFN")
- DO ^PSOPTPST
- IF PSOQFLG
- SET PSOREF("DFLG")=1
- SET PSOQFLG=0
- GOTO NEWPTX
- +1 DO PROFILE^PSOREF1
- NEWPTX QUIT
- +1 ;
- EN(PSOREF) ; Entry Point for Batch Barcode Option
- +1 DO PROCESS
- KILL DRUG,PSODF
- +2 QUIT
