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

PSOATRF.m

Go to the documentation of this file.
  1. PSOATRF ;BIR/MHA - Automate Internet Refill ;Feb 03, 2022@11:08:24
  1. ;;7.0;OUTPATIENT PHARMACY;**264,322,388,313,441**;DEC 1997;Build 208
  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. START ;
  1. N PSOTITFL,PSOPARKED,PSOORIG
  1. S PSOITMG="",U="^",PSOITNS="PSOATRF" S:'$G(DT) DT=$$DT^XLFDT
  1. I '$D(^PS(52.43,"AINST")) S PSOITMG="There are no internet refills/fills to process." G END
  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. I PSOINST']"" S PSOITMG="The Institution "_SITE_" is not defined in the INSTITUTION file (#4)." G END
  1. S PSXSYS=+$O(^PSX(550,"C",""))_"^"_$G(PSOINST)_"^"_$G(PSOUTIL(4,SITE,.01,"E"))
  1. K SITE,DA,PSOUTIL,DIQ
  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. I '$O(^XUSEC("PSOAUTRF","")) S PSOITMG="There are no users with PSOAUTRF key, at least one should have this key." G END
  1. I '$D(^PS(52.43,"AINST",PSOINST)) S PSOITMG="There are no internet refills/fills to process for Institution "_PSOINST G END
  1. L +^XTMP(PSOITNS):3 E S PSOITMG="Automate Internet Refill job is currently running - Try later." G END
  1. K ^XTMP(PSOITNS,$J)
  1. S PSOSYS=$G(^PS(59.7,1,40.1))
  1. S (I,J,PSOITDD)=0 F S I=$O(^PS(59,I)) Q:'I I '$P($G(^PS(59,I,"I")),U)!(DT<$P($G(^("I")),U)) S J=J+1 D G:PSOITMG]"" END
  1. . S PSOSITE(I)=I,PSOSNM(I)=$P(^PS(59,I,0),U),PSORFN(I)=$G(^PS(59,I,"RF")),PSOPAR(I)=$G(^PS(59,I,1)),PSOPRPAS(I)=$P($G(PSOPAR),U,7)
  1. . S PSOPAR7(I)=$G(^PS(59,I,"IB")),PSOPINST(I)=$P($G(^PS(59,I,"INI")),U)
  1. . I J=1 D SDIV S PSOITDD=I
  1. I 'J S PSOITMG="There are no active divisions in File #(59) - At least one division should be active - None processed." G END
  1. D PRORF
  1. END ;
  1. I $D(^XTMP(PSOITNS,$J)) D SMAIL^PSOATRF1 G:'$G(PSOITC) KV
  1. S PSOITMG(1)=$S($G(PSOITC):"Total internet refills/fills processed = "_PSOITC,PSOITMG="":"There are no internet refills/fills to process.",1:PSOITMG)
  1. D GRP
  1. S:'$O(XMY(0)) XMY(DUZ)=""
  1. S XMDUZ=.5,XMSUB="Outpatient Pharmacy - PSO AUTO REFILL"
  1. S XMTEXT="PSOITMG(" N DIFROM D ^XMD K XMDUZ,XMTEXT,XMSUB
  1. KV ;
  1. L -^XTMP(PSOITNS) K ^XTMP(PSOITNS)
  1. K DFN,PSODFN,PSODTCUT,PSOITMG,PSOITNF,PSOITNS,PSOITC,PSOITDD,PSOITF,PSOITP,PSOITR
  1. K PSOINST,PSOPAR,PSOPINST,PSOPRPAS,PSOPAR7,PSOPTPST,PSOSITE,PSOSNM,PSOSYS,PSORFN
  1. K DRG,DIVN,PSXSYS,RX,RX0,RXN,VA,ZZ,LC,PSOS,XMY,PSOREA,PSOSTAT,PSOD
  1. Q
  1. ;
  1. PRORF ;
  1. S X1=DT,X2=-120 D C^%DTC S PSODTCUT=X
  1. S PSOITR="",PSOITC=0
  1. F S PSOITR=$O(^PS(52.43,"AINST",PSOINST,PSOITR)) Q:'PSOITR D D:PSOITMG]"" FILE D ULK
  1. . S (PSOITF,PSOITNF,PSOTITFL)=0,PSOITMG="",PSOITRX=+PSOITR,PSOITP=$O(^PS(52.43,"AINST",PSOINST,PSOITRX,""))
  1. . Q:'PSOITP
  1. . I '$D(^PS(52.43,PSOITP))!($P(^(PSOITP,0),U,5)'="") K ^PS(52.43,"AINST",PSOINST,PSOITRX,PSOITP) Q
  1. . I '$D(^PSRX(PSOITRX,0))!($P(^(0),U)="")!('$D(^(2)))!($P(^("STA"),U)=13) S PSOITNF=1,PSOITMG="Rx IEN "_PSOITRX_" not in file (#52)/Incomplete/Deleted" Q
  1. . D PSOL^PSSLOCK(PSOITRX) I '$G(PSOMSG) K PSOMSG Q
  1. . K PSOMSG
  1. . S PSOITRX0=^PSRX(PSOITRX,0),PSOITRX2=^(2),PSOITRX3=^(3),PSOITRXS=^("STA")
  1. . S (DFN,PSODFN)=$P(PSOITRX0,U,2),RXN=$P(PSOITRX0,U),DRG=$P(PSOITRX0,U,6)
  1. . I PSODFN'=$P(^PS(52.43,PSOITP,0),U,9) D Q
  1. . . S PSOITNF=1,PSOITMG="Can't refill/fill Rx # "_RXN_", it is not for this patient. DFN in file #52="_DFN_", DFN in file #52.43="_$P(^PS(52.43,PSOITP,0),U,9)
  1. . D GET^PSOPTPST
  1. . I $G(PSOPTPST(2,PSODFN,.351))]"" S PSOITNF=1,PSOITMG="Patient Died on "_PSOPTPST(2,PSODFN,.351) Q
  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. . . S PSOITNF=1,PSOITMG="Drug is inactive for Rx # "_RXN_" cannot be refilled/filled"
  1. . S I=$P(^PSRX(PSOITRX,2),U,9) S:'I I=PSOITDD D SDIV
  1. . ;
  1. . I $G(PSOBDIV) D Q
  1. . . S PSOITNF=1
  1. . . S PSOITMG="Inactive division for Rx # "_RXN_". Cannot refill/fill."
  1. . . K PSOBDIV
  1. . ;
  1. . I $G(PSOPTPST(2,PSODFN,.1))]"",'PSORFN S PSOITNF=1,PSOITMG="Patient is an Inpatient on Ward "_PSOPTPST(2,PSODFN,.1) Q
  1. . I $G(PSOPTPST(2,PSODFN,148))="YES",'$P(PSORFN,U,2) S PSOITNF=1,PSOITMG="Patient is in a Contract Nursing Home" Q
  1. . ;
  1. . S PSOORIG=0
  1. . S PSOPARKED=($G(^PSRX(PSOITRX,"STA"))=0)&($G(^PSRX(PSOITRX,"PARK")))
  1. . I PSOPARKED S PSOORIG=$$CHKPRKORIG^PSOPRKA(PSOITRX) ;check if filling original or refill
  1. . ;
  1. . I 'PSOORIG D Q:PSOITNF
  1. . . D CHKRF Q:PSOITNF
  1. . . I $$TITRX^PSOUTL(PSOITRX)="t" D
  1. . . . S PSOITNF=1,PSOITMG="'Titration Rx' cannot be refilled."
  1. . . . S PSOTITFL=1 D FILE
  1. . ;
  1. . I PSOPARKED D UNPARK Q ;441 PAPI
  1. . ;
  1. . I $O(^PS(52.5,"B",PSOITRX,0)),'$G(^PS(52.5,+$O(^PS(52.5,"B",PSOITRX,0)),"P")) S PSOITNF=1,PSOITMG="Rx is in suspense and cannot be refilled" Q
  1. . S PSOY=1+$$LSTRFL^PSOBPSU1(PSOITRX)
  1. . I PSOY>$P(PSOITRX0,U,9) S PSOITNF=1,PSOITMG="Can't refill, no refills remaining" Q
  1. . S (PSOITF,PSOX("NUMBER"))=PSOY
  1. . S PSOX("RX0")=PSOITRX0,PSOX("RX2")=PSOITRX2,PSOX("RX3")=PSOITRX3,PSOX("STA")=PSOITRXS
  1. . S DRG=$P(PSOITRX0,U,6)
  1. . N PSODEA,PSODAY,PSOCHECK
  1. . S PSODEA=$P($G(^PSDRUG(DRG,0)),U,3)
  1. . S PSODAY=$P(PSOITRX0,U,8)
  1. . S PSOCHECK=$$DEACHK^PSOUTLA1(PSOITRX,PSODEA,PSODAY)
  1. . I PSOCHECK S PSOITNF=1 D Q
  1. . . I PSOCHECK=1 S PSOITMG="Requested refill exceeds maximum allowable days supply for Rx." Q ;*388
  1. . . S PSOITMG="Current drug DEA/SPECIAL HANDLING code does not allow refills." ;*388
  1. . D CHKDT Q:PSOITNF
  1. . D EN^PSOR52(.PSOX) I PSOITF,$D(^PSRX(PSOITRX,1,PSOITF,0)) S PSOITC=PSOITC+1,PSOITMG=PSOITF_" Susp. until "_$$DSP($P(^(0),U))
  1. Q
  1. ;
  1. CHKRF ;
  1. D ^PSOBUILD
  1. I '$G(PSOSD) S PSOITNF=1,PSOITMG="This patient has no prescriptions" Q
  1. S (PSOX,PSOY,PSOS)="",PSOX("STA")=PSOITRXS
  1. F S PSOS=$O(PSOSD(PSOS)) Q:PSOS="" F S PSOX=$O(PSOSD(PSOS,PSOX)) Q:PSOX']"" D
  1. . I PSOITRX=+PSOSD(PSOS,PSOX) S PSOY=PSOSD(PSOS,PSOX) I $P(PSOY,U,4)]"" D
  1. . . S PSOITNF=1,PSOITMG="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
  1. . . . D STATUS^PSODI(52,100,"PSOB")
  1. . . . S PSOA=$F(PSOB("POINTER"),PSOA)
  1. . . . S PSOA=$P($E(PSOB("POINTER"),PSOA,999),";",1)
  1. . . . S PSOITMG=PSOITMG_" Rx is in "_$P(PSOA,":",2)_" status"
  1. . . . K PSOA,PSOB
  1. . . I PSOREA["M" S PSOITMG=PSOITMG_" Drug no longer used by Outpatient Pharmacy" Q
  1. . . I PSOREA["B" S PSOITMG=PSOITMG_" Narcotic Drug" Q
  1. . . I PSOREA["C" S PSOITMG=PSOITMG_" Non-Renewable Drug" Q
  1. . . I PSOREA["D" S PSOITMG=PSOITMG_" Non-Renewable Patient Status" Q
  1. . . I PSOREA["E" S PSOITMG=PSOITMG_" Non-Verified Rx" Q
  1. . . I PSOREA["G",PSOREA'["B" S PSOITMG=PSOITMG_" No more refills left"
  1. I PSOY="" S PSOITNF=1,PSOITMG="Cannot refill, Rx is DC/Exp. Later Rx may exist " D
  1. . S (PSOS,PSOX)="",PSOD=$P(^PSDRUG($P(PSOITRX0,U,6),0),U)
  1. . N ZRX S ZRX="" F S PSOS=$O(PSOSD(PSOS)) Q:PSOS="" F S PSOX=$O(PSOSD(PSOS,PSOX)) Q:PSOX']"" I PSOD=PSOX,+PSOSD(PSOS,PSOX) S ZRX=$P($G(^PSRX(+PSOSD(PSOS,PSOX),0)),U)
  1. . S PSOITMG=PSOITMG_ZRX
  1. Q
  1. ;
  1. FILE ;
  1. K DIE S DA=PSOITP
  1. S DIE="^PS(52.43,",DR="5////"_DT_";6///"_$S(PSOITNF&'$G(PSOTITFL):"NOT ",1:"")_"FILLED;10////"_PSOITMG D ^DIE
  1. K ^PS(52.43,"AINST",PSOINST,PSOITRX,DA) I PSOITNF S ^XTMP(PSOITNS,$J,PSOSITE,DFN,PSOITRX)=PSOITMG
  1. Q
  1. ;
  1. GRP ;
  1. S MDUZ=0
  1. I '$D(^XUSEC("PSOAUTRF")) D Q
  1. . F S MDUZ=$O(^XUSEC("PSORPH",MDUZ)) Q:MDUZ'>0 S XMY(MDUZ)=""
  1. F S MDUZ=$O(^XUSEC("PSOAUTRF",MDUZ)) Q:MDUZ'>0 S XMY(MDUZ)=""
  1. K MDUZ Q
  1. ;
  1. ULK ;
  1. I '$G(PSOITRX) Q
  1. D PSOUL^PSSLOCK(PSOITRX)
  1. K PSOITRX,PSOSD,PSOX,PSORX,PSOITRX0,PSOITRX2,PSOITRX3,PSOITRXS
  1. Q
  1. SETUP ;
  1. I '$D(^XUSEC("PSOAUTRF",DUZ)) W !,"You must hold the PSOAUTRF key to run this option!" Q
  1. N PATCH,JOBN
  1. S JOBN="PSO AUTO REFILL"
  1. L +^XTMP("PSOATRF"):5 I '$T D Q
  1. .D BMES^XPDUTL("The Refill Automation job is currently running, try later.")
  1. .D MES^XPDUTL("")
  1. .S DIR(0)="E",DIR("A")=" Press ENTER to Continue" D ^DIR K DIR
  1. K %DT,DIC,DTOUT S DIC(0)="XZM",DIC="^DIC(19.2,",X="PSO AUTO REFILL" D ^DIC
  1. I +Y>0 D EDIT^XUTMOPT("PSO AUTO REFILL") G EX
  1. D RESCH^XUTMOPT("PSO AUTO REFILL","","","24H","L"),EDIT^XUTMOPT("PSO AUTO REFILL") K DIC,Y,X
  1. EX ;
  1. L -^XTMP("PSOATRF") K Y,C,D,D0,DI,DQ,DA,DIE,DR,DIC,X
  1. Q
  1. ;
  1. SDIV ;
  1. S PSOSITE=$G(PSOSITE(I)) I 'PSOSITE S PSOSITE=I,PSOBDIV=1 Q
  1. S PSOPAR=PSOPAR(I),PSOPRPAS=PSOPRPAS(I),PSORFN=PSORFN(I)
  1. S PSOPAR7=PSOPAR7(I),PSOPINST=PSOPINST(I)
  1. Q
  1. ;
  1. CHKDT ;
  1. S PSOX("IRXN")=PSOITRX
  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(PSOITRX2,U,6) D NEXT
  1. I PSOX("FILL DATE")<$P(PSOITRX3,U,2) D SUSDATE^PSOUTIL(.PSOX)
  1. I PSOX("FILL DATE")>PSOX("STOP DATE") S PSOITNF=1 D Q
  1. .S PSOITMG="Can't refill, Refill Date "_$$DSP(PSOX("FILL DATE"))
  1. .S PSOITMG=PSOITMG_" is past Expiration Date "_$$DSP(PSOX("STOP DATE"))
  1. S PSOX("LAST REFILL DATE")=$P(PSOITRX3,U,1)
  1. I PSOX("LAST REFILL DATE"),PSOX("FILL DATE")=PSOX("LAST REFILL DATE") S PSOITNF=1 D Q
  1. .S PSOITMG="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") S PSOITNF=1 D Q
  1. .S PSOITMG="Can't refill, later Refill Date already exists for "_$$DSP(PSOX("LAST REFILL DATE"))
  1. Q
  1. ;
  1. NEXT ;
  1. S PSOX1=$P(PSOITRX2,U,2)
  1. I '$O(^PSRX(PSOITRX,1,0)) D Q
  1. . S $P(PSOITRX3,U)=PSOX1,X1=PSOX1
  1. . S X2=$P(PSOITRX0,U,8)-10\1
  1. . D C^%DTC
  1. . S:'$P(PSOITRX3,U,8) $P(PSOITRX3,U,2)=X K X
  1. S PSOY2=0
  1. F PSOY=0:0 S PSOY=$O(^PSRX(PSOITRX,1,PSOY)) Q:'PSOY S PSOY1=PSOY,PSOY2=PSOY2+1
  1. S PSOY=^PSRX(PSOITRX,1,PSOY1,0)
  1. S PSOX2=$P(PSOY,U)
  1. S $P(PSOITRX3,U)=PSOX2,X1=PSOX2
  1. S X2=$P(PSOITRX0,U,8)-10\1
  1. D C^%DTC S PSOY3=X
  1. S X1=PSOX1,X2=(PSOY2+1)*$P(PSOITRX0,U,8)-10\1
  1. D C^%DTC S PSOY4=X
  1. S $P(PSOITRX3,U,2)=$S(PSOY3<PSOY4:PSOY4,1:PSOY3)
  1. K X,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. UNPARK ; 441 PAPI
  1. N PSOARR,PSOERRMSG,PSOITF,PSOLASTREFILL
  1. ;
  1. S PSOLASTREFILL=$$LSTRFL^PSOBPSU1(PSOITRX)
  1. ;
  1. D UNPARK^PSOPRKA(PSOITRX,PSODFN,.PSOERRMSG,.PSOARR) ; UNPARK regardless of original or refill
  1. ;
  1. S PSOITF=$$LSTRFL^PSOBPSU1(PSOITRX)
  1. I (PSOLASTREFILL+1)'=PSOITF S PSOITF=0 ; If refill # was not incremented, than was not processed as a refill
  1. ;
  1. ; error - was not able to fill
  1. I $G(PSOERRMSG(1))'="" D Q
  1. . S PSOITNF=1
  1. . S PSOITMG=PSOERRMSG(1) ; message if unable to fill/refill
  1. . I PSOITMG["Titration Rx" S PSOTITFL=1
  1. ;
  1. ; original fill was put on suspense
  1. I $G(PSOARR("UPKSUSPCOMM"))'="" D Q
  1. . S PSOITMG=PSOARR("UPKSUSPCOMM")
  1. . S PSOITC=PSOITC+1
  1. ;
  1. ; new refill was generated
  1. I PSOITF,$D(^PSRX(PSOITRX,1,PSOITF,0)) D
  1. . S PSOITC=PSOITC+1
  1. . S PSOITMG=PSOITF_" Susp. until "_$$DSP($P($G(^PSRX(PSOITRX,1,PSOITF,0)),U,1))
  1. E D ; if none of the above scenarios occurred, unknown issue
  1. . S PSOITNF=1
  1. . S PSOITMG="Unexpected issue when processing parked RX refill/fill."
  1. ;
  1. Q
  1. ;