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