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

PSOATRFV.m

Go to the documentation of this file.
  1. PSOATRFV ;BIR/MHA,KML - Automate VCC Refill request ;April 11,2022
  1. ;;7.0;OUTPATIENT PHARMACY;**642,679**;DEC 1997;Build 16
  1. ;Reference to ^PSSLOCK supported by DBIA 2789
  1. ;Reference ^PSDRUG supported by DBIA 221
  1. ;Reference ^PS(55 supported by DBIA 2228
  1. ;
  1. REF(PSORXN,PSOUSR,PSORFSRC,PSOITMG) ;process refill request
  1. ; Input:
  1. ; PSORX (required) - Prescription Number
  1. ; PSOUSR (optional) - User requesting refill
  1. ; PSORFSRC (optional) - the source system from which the REFILL
  1. ; request Originated (e.g., AUDIOCARE, VCC, CPRS, VSE)
  1. ; PSOITMG - error array
  1. N DFN,PSODFN,PSODTCUT,PSOITNS,PSOITDD,PSOITNF,PSOITF,DIV
  1. N PSOITP,PSOITR,PSOINST,PSOPAR,PSOPINST,PSOPRPAS,PSOPAR7,PSOPTPST
  1. N PSOSITE,PSOSNM,PSOSYS,PSORFN,PSOREA,PSOSTAT,PSOD,PSOS,DRG,DIVN
  1. N PSXSYS,RX,RX0,RXN,VA,ZZ,LC,XMY,PSORXN0,PSORXN2,PSORXN3,PSORXNS
  1. N DA,DIC,DIQ,DR,PSOFROM,PSORX,PSOX,PSOUTIL,SITE,PSOSD
  1. ;
  1. S (DIV,PSOSITE)=$P(^PSRX(PSORXN,2),"^",9)
  1. S (SITE,DA)=$P(^XMB(1,1,"XUS"),U,17),DIC="4",DIQ(0)="IE",DR=".01;99",DIQ="PSOUTIL" D EN^DIQ1
  1. S PSOINST=$G(PSOUTIL(4,SITE,99,"I"))
  1. S PSOPAR=$G(^PS(59,DIV,1)),PSORFN=$G(^PS(59,DIV,"RF")),PSOITNF=0
  1. S PSXSYS=+$O(^PSX(550,"C",""))_"^"_$G(PSOINST)_"^"_$G(PSOUTIL(4,SITE,.01,"E"))
  1. I $G(PSXSYS) D
  1. . K:($P($G(^PSX(550,+PSXSYS,0)),"^",2)'="A") PSXSYS
  1. . I $$VERSION^XPDUTL("PSO")<7.0 K PSXSYS
  1. S PSOSYS=$G(^PS(59.7,1,40.1))
  1. ;
  1. I '$D(^PSRX(PSORXN,0))!($P(^(0),U)="")!('$D(^(2)))!($P(^("STA"),U)=13) D Q
  1. . D ERR("Rx IEN "_PSORXN_" not in file (#52)/Incomplete/Deleted")
  1. S PSORXN0=^PSRX(PSORXN,0),PSORXN2=^(2),PSORXN3=^(3),PSORXNS=^("STA")
  1. S (DFN,PSODFN)=$P(PSORXN0,U,2),RXN=$P(PSORXN0,U),DRG=$P(PSORXN0,U,6)
  1. D GET^PSOPTPST
  1. I $G(PSOPTPST(2,PSODFN,.351))]"" D Q
  1. . D ERR("Patient Died on "_PSOPTPST(2,PSODFN,.351))
  1. D ICN^PSODPT(DFN)
  1. S PSOLOUD=1 D:$P($G(^PS(55,DFN,0)),U,6)'=2 EN^PSOHLUP(DFN) K PSOLOUD
  1. I '$P(PSOPAR,U,11),$G(^PSDRUG(DRG,"I"))]"",DT>$G(^("I")) D Q
  1. . D ERR("Drug is inactive for Rx # "_RXN_" cannot be refilled")
  1. I $G(PSOPTPST(2,PSODFN,.1))]"",'PSORFN D Q
  1. . D ERR("Patient is an Inpatient on Ward "_PSOPTPST(2,PSODFN,.1))
  1. I $G(PSOPTPST(2,PSODFN,148))="YES",'$P(PSORFN,U,2) D Q
  1. . D ERR("Patient is in a Contract Nursing Home")
  1. D CHKRF Q:PSOITNF ;Quit if RX not refillable
  1. ;
  1. ;more checks
  1. I $O(^PS(52.5,"B",PSORXN,0)),'$G(^PS(52.5,+$O(^PS(52.5,"B",PSORXN,0)),"P")) D Q
  1. . D ERR("Rx is in suspense and cannot be refilled")
  1. S PSOY=1+$$LSTRFL^PSOBPSU1(PSORXN)
  1. I PSOY>$P(PSORXN0,U,9) D Q
  1. . D ERR("Can't refill, no refills remaining")
  1. S (PSOITF,PSOX("NUMBER"))=PSOY
  1. S PSOX("RX0")=PSORXN0,PSOX("RX2")=PSORXN2,PSOX("RX3")=PSORXN3,PSOX("STA")=PSORXNS
  1. S DRG=$P(PSORXN0,U,6)
  1. N PSODEA,PSODAY,PSOCHECK
  1. S PSODEA=$P($G(^PSDRUG(DRG,0)),U,3)
  1. S PSODAY=$P(PSORXN0,U,8)
  1. S PSOCHECK=$$DEACHK^PSOUTLA1(PSORXN,PSODEA,PSODAY)
  1. I PSOCHECK=1 D ERR("Requested refill exceeds maximum allowable days supply for Rx.") Q ;*388
  1. I PSOCHECK=2 D ERR("Current drug DEA/SPECIAL HANDLING code does not allow refills.") Q ;*388
  1. D CHKDT Q:PSOITNF ;Quit if not refillable
  1. ;
  1. ; Titration Marked Rx
  1. I $$TITRX^PSOUTL(PSORXN)="t" D Q
  1. . D ERR("'Titration Rx' cannot be refilled.")
  1. ;
  1. ;ok to process refill
  1. D EN^PSOR52(.PSOX)
  1. ;add additional activity log comment to refill just added
  1. I PSOITF,$D(^PSRX(PSORXN,1,PSOITF,0)) D
  1. . S PSORFSRC=$G(PSORFSRC)
  1. . S ^PSRX(PSORXN,1,PSOITF,"RF1")=$S(PSORFSRC]"":PSORFSRC,1:"UNKNOWN")_"^"_$G(PSOUSR)
  1. . N AL,DONE,PSOFDA
  1. . S AL="",DONE=0
  1. . F S AL=$O(^PSRX(PSORXN,"A",AL),-1) Q:'AL D Q:DONE
  1. . . Q:$P(^PSRX(PSORXN,"A",AL,0),U,4)'=PSOITF
  1. . . S PSOFDA(52.34,"+3,"_AL_","_PSORXN_",",.01)=$S(PSORFSRC]"":PSORFSRC,1:"UNKNOWN")
  1. . . D UPDATE^DIE("","PSOFDA")
  1. . . S DONE=1
  1. Q
  1. ;
  1. CHKRF ;check prescription if still refillable
  1. S X2=-120,X1=DT D C^%DTC S PSODTCUT=X
  1. D ^PSOBUILD
  1. I '$G(PSOSD) D Q
  1. . D ERR("This patient has no prescriptions")
  1. S (PSOX,PSOY,PSOS)="",PSOX("STA")=PSORXNS
  1. F S PSOS=$O(PSOSD(PSOS)) Q:PSOS="" F S PSOX=$O(PSOSD(PSOS,PSOX)) Q:PSOX']"" D
  1. . I PSORXN=+PSOSD(PSOS,PSOX) S PSOY=PSOSD(PSOS,PSOX) I $P(PSOY,U,4)]"" D
  1. . . D ERR("Cannot refill Rx # "_RXN)
  1. . . S PSOREA=$P(PSOY,U,4),PSOSTAT=PSOX("STA")
  1. . . I PSOREA["Z" S:PSOSTAT=4 PSOSTAT=1 D Q
  1. . . . S PSOA=";"_PSOSTAT,PSOB=$P(^DD(52,100,0),U,3)
  1. . . . S PSOA=$F(PSOB,PSOA),PSOA=$P($E(PSOB,PSOA,999),";",1)
  1. . . . D ERR(" Rx is in "_$P(PSOA,":",2)_" status")
  1. . . . K PSOA,PSOB
  1. . . I PSOREA["M" D ERR("Drug no longer used by Outpatient Pharmacy") Q
  1. . . I PSOREA["B" D ERR("Narcotic Drug") Q
  1. . . I PSOREA["C" D ERR("Non-Renewable Drug") Q
  1. . . I PSOREA["D" D ERR("Non-Renewable Patient Status") Q
  1. . . I PSOREA["E" D ERR("Non-Verified Rx") Q
  1. . . I PSOREA["G",PSOREA'["B" D ERR("No more refills left")
  1. I PSOY="" D ERR("Cannot refill, Rx is DC/Exp. Later Rx may exist") D
  1. . S (PSOS,PSOX)="",PSOD=$P(^PSDRUG($P(PSORXN0,U,6),0),U)
  1. . N ZRX S ZRX=""
  1. . F S PSOS=$O(PSOSD(PSOS)) Q:PSOS="" D
  1. . . F S PSOX=$O(PSOSD(PSOS,PSOX)) Q:PSOX="" D
  1. . . . I PSOD=PSOX,+PSOSD(PSOS,PSOX) S ZRX=$P($G(^PSRX(+PSOSD(PSOS,PSOX),0)),U)
  1. . D ERR(ZRX)
  1. Q
  1. ;
  1. CHKDT ;check date on this refill request
  1. N X1,X2
  1. S PSOX("IRXN")=PSORXN
  1. S PSOX("MAIL/WINDOW")="M",PSOX("FLD")=2,PSOX("QS")="S"
  1. S PSOX("FIELD")=0,(PSORX("FILL DATE"),PSOX("FILL DATE"))=DT,PSOX("FLD")=1,X1=DT,X2=-180
  1. D C^%DTC S PSOX("ISSUE DATE")=X,PSOX("CLERK CODE")=DUZ
  1. S PSOX("STOP DATE")=$P(PSORXN2,U,6) D NEXT
  1. I PSOX("FILL DATE")<$P(PSORXN3,U,2) D SUSDATE^PSOUTIL(.PSOX)
  1. I PSOX("FILL DATE")>PSOX("STOP DATE") D Q
  1. . D ERR("Can't refill, Refill Date "_$$DSP(PSOX("FILL DATE")))
  1. . D ERR("is past Expiration Date "_$$DSP(PSOX("STOP DATE")))
  1. S PSOX("LAST REFILL DATE")=$P(PSORXN3,U,1)
  1. I PSOX("LAST REFILL DATE"),PSOX("FILL DATE")=PSOX("LAST REFILL DATE") D Q
  1. . D ERR("Can't refill, Fill Date already exists for "_$$DSP(PSOX("FILL DATE")))
  1. I PSOX("LAST REFILL DATE"),PSOX("FILL DATE")<PSOX("LAST REFILL DATE") D Q
  1. . D ERR("Can't refill, later Refill Date already exists for "_$$DSP(PSOX("LAST REFILL DATE")))
  1. Q
  1. ;
  1. NEXT ;
  1. S PSOX1=$P(PSORXN2,U,2)
  1. I '$O(^PSRX(PSORXN,1,0)) D Q
  1. . S $P(PSORXN3,U)=PSOX1,X1=PSOX1
  1. . S X2=$P(PSORXN0,U,8)-10\1
  1. . D C^%DTC
  1. . S:'$P(PSORXN3,U,8) $P(PSORXN3,U,2)=X K X
  1. S PSOY2=0
  1. F PSOY=0:0 S PSOY=$O(^PSRX(PSORXN,1,PSOY)) Q:'PSOY S PSOY1=PSOY,PSOY2=PSOY2+1
  1. S PSOY=^PSRX(PSORXN,1,PSOY1,0)
  1. S PSOX2=$P(PSOY,U)
  1. S $P(PSORXN3,U)=PSOX2,X1=PSOX2
  1. S X2=$P(PSORXN0,U,8)-10\1
  1. D C^%DTC S PSOY3=X
  1. S X1=PSOX1,X2=(PSOY2+1)*$P(PSORXN0,U,8)-10\1
  1. D C^%DTC S PSOY4=X
  1. S $P(PSORXN3,U,2)=$S(PSOY3<PSOY4:PSOY4,1:PSOY3)
  1. K X,X1,X2,PSOX1,PSOX2,PSOY,PSOY1,PSOY2,PSOY3,PSOY4
  1. Q
  1. ;
  1. DSP(X) ;
  1. Q:'X ""
  1. Q $E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
  1. ;
  1. ERR(TXT) ;Build error text array
  1. ; add TXT to end of last line in array, if will fit, else
  1. ; add it as a new last line and indented 3.
  1. ; and set error flag
  1. N II S II=$O(PSOITMG(""),-1) S:'II II=1
  1. S PSOITNF=1
  1. I $L($G(PSOITMG(II)))+$L(TXT)>79 D
  1. . S PSOITMG(II+1)=" "_TXT
  1. E D
  1. . S PSOITMG(II)=$G(PSOITMG(II))_" "_TXT
  1. Q
  1. ;
  1. MAILMSG(DFN,RXN,ERRTXT) ;send alert via mailman msg to PSOAUTRF key holders
  1. N MDUZ,XMDUZ,XMTEXT,XMSUB,PTNAME,PTSSN,DIV,DIVN
  1. D DEM^VADPT
  1. S PTNAME=$P(VADM(1),"^"),PTSSN=$P($P(VADM(2),"^",2),"-",3) K VADM
  1. S DIV=$$RXSITE^PSOBPSUT(RXN,0),DIVN=$P($G(^PS(59,DIV,0)),"^")
  1. S MDUZ=0
  1. F S MDUZ=$O(^XUSEC("PSOAUTRF",MDUZ)) Q:MDUZ'>0 S XMY(MDUZ)=""
  1. S XMDUZ=.5,XMSUB=DIVN_" VCC AUTO REFILL - Not Processed List"
  1. S ERRTXT(.1)="VCC requested an Outpatient refill, but was not allowed for the below reason:"
  1. S ERRTXT(.2)=""
  1. S ERRTXT(.3)=" Patient: "_PTNAME_" ("_PTSSN_")"
  1. S ERRTXT(.4)=" Rx #: "_$$GET1^DIQ(52,RXN,.01)
  1. S ERRTXT(.5)=" Drug: "_$$GET1^DIQ(52,RXN,6)
  1. S ERRTXT(.6)=""
  1. S XMTEXT="ERRTXT(" N DIFROM
  1. D ^XMD
  1. Q