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

PSORREF0.m

Go to the documentation of this file. 
  1. PSORREF0 ;AITC/BWF  Remote RX refill API ;7/15/16 1:57am
  1.  ;;7.0;OUTPATIENT PHARMACY;**454,497**;DEC 1997;Build 25
  1.  ;
  1.  ;External reference to ^PSDRUG supported by DBIA 221
  1.  ;
  1.  ; Modified copy of ^PSOREF0 for the OneVA Pharmacy Project - remote prescriptions
  1.  ;
  1.  ;PSO*186 add check for DEA Special handling field refill restrictions
  1.  Q
  1. PROCESS(PSORMSG) ;
  1.  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)
  1.  S PSOREF("DAYS SUPPLY")=$P(PSOREF("RX0"),"^",8)
  1.  K ZD(PSOREF("IRXN"))   ;*306
  1.  S PSOREF("DFLG")=0 D DSPLY G:PSOREF("DFLG") PROCESSX
  1.  D CHECK Q:$G(PSODF)  G:PSOREF("DFLG") PROCESSX D EN^PSOR52(.PSOREF)
  1.  ;D CHECK G:$G(PSODF) PROCESS G:PSOREF("DFLG") PROCESSX D EN^PSOR52(.PSOREF)
  1. PROCESSX ;D:$G(PSOREF("OLD FILL DATE"))]"" SUSDATEK^PSOUTIL(.PSOREF)
  1.  Q
  1. DSPLY ;
  1.  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)
  1.  K FSIG,PSREV I '$P($G(^PSRX(PSOREF("IRXN"),"SIG")),"^",2) D EN2^PSOUTLA1(PSOREF("IRXN"),54)
  1.  I $O(BSIG(1)) F PSREV=1:0 S PSREV=$O(BSIG(PSREV)) Q:'PSREV  W !?24,$G(BSIG(PSREV))
  1.  K BSIG,PSREV
  1. DSPLYX Q
  1. CHECK ;
  1.  N STA
  1.  I '$P(PSOPAR,"^",11),$G(^PSDRUG($P(PSOREF("RX0"),"^",6),"I"))]"",DT>$G(^("I")) D  G CKQ
  1.  .S PSORMSG(1)=" *** Drug is inactive for Rx # "_$P(PSOREF("RX0"),"^")_" cannot be refilled ***"
  1.  I PSOREF("PSODFN")'=PSODFN S PSORMSG(1)="Can't refill Rx # "_$P(PSOREF("RX0"),"^")_", it is not for this patient." G CKQ
  1.  S (PSOX,PSOY,STA)=""
  1.  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
  1.  . S PSOREF("DFLG")=1 S:'$G(PSOERR) PSORMSG(1)="Cannot refill Rx # "_$P(PSOREF("RX0"),"^") S PSOREA=$P(PSOY,"^",4),PSOSTAT=PSOREF("STA")
  1.  . D STATUS(PSOREA,PSOSTAT,.PSORMSG) K PSOREA,PSOSTAT
  1.  . Q
  1.  I PSOY="" S PSORMSG(1)="Cannot refill, Rx is discontinued or expired.  Later Rx may exist." D  I $G(PSODF) Q
  1.  .D LOOK I $G(PSODF) Q
  1.  .S PSOREF("DFLG")=1
  1.  K PSOX,PSOY G:PSOREF("DFLG") CHECKX
  1.  I $O(^PS(52.5,"B",PSOREF("IRXN"),0)),'$G(^PS(52.5,+$O(^PS(52.5,"B",PSOREF("IRXN"),0)),"P")) S PSORMSG(1)="Rx is in suspense and cannot be refilled" S PSOREF("DFLG")=1 G CHECKX
  1.  S PSOREF("RXSTATUS")=PSOREF("STA")
  1.  I PSOREF("RXSTATUS"),PSOREF("RXSTATUS")'=6 D  G CHECKX
  1.  . S PSOY=";"_PSOREF("RXSTATUS"),PSOX=$P(^DD(52,100,0),"^",3),PSOY=$F(PSOX,PSOY),PSOY=$P($E(PSOX,PSOY,999),";",1)   ;IA#999
  1.  . S PSORMSG(1)="Rx is in "_PSOY_" status, cannot be refilled" S PSOREF("DFLG")=1
  1.  D CHKDIV G:PSOREF("DFLG") CHECKX
  1.  D NUMBER I PSOREF("NUMBER")>$P(PSOREF("RX0"),"^",9) S PSORMSG(1)="Can't refill, no refills remaining." S PSOREF("DFLG")=1 G CHECKX
  1.  ;PSO*7*186  check DEA, SPEC HNDLG field, in case changed, and apply
  1.  N PSODRG,PSODEA,PSODAY
  1.  S PSODRG=$G(^PSDRUG($P(PSOREF("RX0"),U,6),0)),PSODEA=$P(PSODRG,U,3)
  1.  S PSODAY=$P(PSOREF("RX0"),U,8)
  1.  I $$DEACHK^PSOUTLA1(PSOREF("IRXN"),PSODEA,PSODAY) D  G CHECKX
  1.  . S PSORMSG(1)="This drug has been changed, No refills allowed"
  1.  . S PSOREF("DFLG")=1
  1.  D DATES
  1. CHECKX Q
  1. CKQ ;
  1.  S PSOREF("DFLG")=1 D PAUSE^VALM1 G CHECKX
  1.  Q
  1.  ;
  1.  ; PSO*7*497 - quitting at CHKDIV function, the logic that was executed does not apply to OneVA Pharmacy, per Rob Silverman
  1. CHKDIV Q
  1. CHKDIVX Q
  1.  ;
  1. NUMBER K PSOX,PSOY S PSOREF("# OF REFILLS")=0
  1.  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
  1.  S PSOREF("NUMBER")=PSOREF("# OF REFILLS")+1
  1.  Q
  1.  ;
  1. DATES S PSOREF("STOP DATE")=$P(PSOREF("RX2"),"^",6) D NEXT^PSOUTIL(.PSOREF)
  1.  D:$G(PSOBBC("QFLG"))&($P(PSOPAR,"^",6)) EDATE Q:$G(PSOREF("DFLG"))
  1.  S PSOREF("FILL DATE")=$S($G(PSOREF("FILL DATE")):PSOREF("FILL DATE"),1:DT)
  1.  ;I $P(PSOPAR,"^",6),PSOREF("FILL DATE")<$P(PSOREF("RX3"),"^",2) D SUSDATE^PSOUTIL(.PSOREF)
  1.  ;
  1.  I PSOREF("FILL DATE")>PSOREF("STOP DATE") D
  1.  . S PSORMSG(1)="Can't refill, Refill Date "_$E(PSOREF("FILL DATE"),4,5)_"/"_$E(PSOREF("FILL DATE"),6,7)_"/"
  1.  . S PSORMSG(2)=$E(PSOREF("FILL DATE"),2,3)_" is past Expiration Date "_$E(PSOREF("STOP DATE"),4,5)_"/"_$E(PSOREF("STOP DATE"),6,7)_"/"
  1.  . S PSORMSG(3)=$E(PSOREF("STOP DATE"),2,3) S PSOREF("DFLG")=1
  1. EDATE S PSOREF("LAST REFILL DATE")=$P(PSOREF("RX3"),"^",1)
  1.  I PSOREF("LAST REFILL DATE"),PSOREF("FILL DATE")=PSOREF("LAST REFILL DATE") D  G DATESX
  1.  . S PSORMSG(1)="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)
  1.  . S PSOREF("DFLG")=1
  1.  I PSOREF("LAST REFILL DATE"),PSOREF("FILL DATE")<PSOREF("LAST REFILL DATE") D  G DATESX
  1.  . S PSORMSG(1)="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)
  1.  . S PSOREF("DFLG")=1
  1.  ; PSO*7*497 - removing this check, as it is not needed.
  1.  ;I '$P(PSOPAR,"^",6),'$D(PSOREF("EAOK")),$P(PSOREF("RX3"),"^",2)>PSOREF("FILL DATE") D
  1.  ;. S PSOX1=(PSOREF("NUMBER")+1)*PSOREF("DAYS SUPPLY")-10
  1.  ;. ; PSO*7*497 - replacing line below with one that follows (auto-suspend defect - do not allow bypass)
  1.  ;. ;W !?5,$C(7),"LESS THAN ",PSOX1," DAYS FOR ",PSOREF("NUMBER")+1," FILLS",! D DIR K PSOX1
  1.  ;. S PSORMSG(1)="LESS THAN "_PSOX1_" DAYS FOR "_PSOREF("NUMBER")+1_" FILLS" S (PSOREF("DFLG"),PSOMHV)=1 K PSOX1
  1.  ; PSO(7*497 - replacing line below with the one that follows - EAOK check and auto-suspend flag are irrelevant for oneva pharmacy
  1.  ;I '$P(PSOPAR,"^",6),$G(PSOREF("EAOK"))=0,$P(PSOREF("RX3"),"^",2)>PSOREF("FILL DATE") D
  1.  I $P(PSOREF("RX3"),"^",2)>PSOREF("FILL DATE") D
  1.  . ; PSO*7*497 - replacing line below with one that follows (auto-suspend defect)
  1.  . ;S Y=$P(PSOREF("RX3"),"^",2) D DD^%DT W !!,$C(7),"Cannot be refilled until "_Y_"." S (PSOREF("DFLG"),PSOMHV)=1 K Y
  1.  . S Y=$P(PSOREF("RX3"),"^",2) D DD^%DT S PSORMSG(1)="Cannot be refilled until "_Y_"." S (PSOREF("DFLG"))=1 K Y
  1. DATESX Q
  1.  ; PSO*497 - quit at DIR. This is not used for oneva pharmacy.
  1. DIR ;
  1.  Q
  1.  ;
  1. EN(PSOREF)         ; Entry Point for Batch Barcode Option
  1.  D PROCESS K DRUG,PSODF
  1.  Q
  1. LOOK ;this entry is used to try and find current med order
  1.  S (PSOY,STA,PSOX)="",DRUG=$P(^PSDRUG($P(^PSRX(PSOREF("IRXN"),0),"^",6),0),"^")
  1.  I $G(PSOSD) F  S STA=$O(PSOSD(STA)) Q:STA=""  F  S PSOX=$O(PSOSD(STA,PSOX)) Q:PSOX']""  I DRUG=PSOX,+PSOSD(STA,PSOX) S PSOY=PSOSD(STA,PSOX),PSOREF("IRXN")=+PSOSD(STA,PSOX),PSODF=1,PSOBBC("DONE")=PSOREF("IRXN")_"," Q
  1.  K DRUG
  1.  Q
  1.  ;
  1. STATUS(PSOREA,PSOSTAT,PSORMSG) ;
  1.  N DSMSG,PSOA,PSOB,TARGET
  1.  S DSMSG=PSORMSG(1)
  1.  I PSOREA["A" S DSMSG=DSMSG_" Inactive Drug."
  1.  I PSOREA["M" S DSMSG=DSMSG_" Drug no longer used by Outpatient."
  1.  I PSOREA["B" S DSMSG=DSMSG_" Narcotic Drug."
  1.  I PSOREA["C" S DSMSG=DSMSG_" Non-Renewable Drug."
  1.  I PSOREA["D" S DSMSG=DSMSG_" Non-Renewable Patient Status."
  1.  I PSOREA["E" S DSMSG=DSMSG_" Non-Verified Rx."
  1.  I PSOREA["F" S DSMSG=DSMSG_" Maximum of 26 Renewals."
  1.  I PSOREA["G" S DSMSG=DSMSG_" No refills left."
  1.  I PSOREA["Z" D
  1.  . S:PSOSTAT=4 PSOSTAT=1
  1.  . S PSOA=";"_PSOSTAT
  1.  . D FIELD^DID(52,100,,"POINTER","TARGET")
  1.  . S PSOB=$G(TARGET("POINTER"))
  1.  . Q:PSOB=""
  1.  . S PSOA=$F(PSOB,PSOA),PSOA=$P($E(PSOB,PSOA,999),";",1)
  1.  . S DSMSG=DSMSG_" Rx is in "_$P(PSOA,":",2)_" status."
  1.  . K PSOA,PSOB
  1.  . Q
  1.  S PSORMSG(1)=DSMSG
  1.  Q