PSOATRFC ;BIR/MHA - Automate CPRS Refill request ;Jul 13, 2021@14:18:47
;;7.0;OUTPATIENT PHARMACY;**305,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
;
REF(PSORXN,PSOITMG) ;process refill request
N DFN,PSODFN,PSODTCUT,PSOITNS,PSOITDD,PSOITNF,PSOITF,DIV
N PSOITP,PSOITR,PSOINST,PSOPAR,PSOPINST,PSOPRPAS,PSOPAR7,PSOPTPST
N PSOSITE,PSOSNM,PSOSYS,PSORFN,PSOREA,PSOSTAT,PSOD,PSOS,DRG,DIVN
N PSXSYS,RX,RX0,RXN,VA,ZZ,LC,XMY,PSORXN0,PSORXN2,PSORXN3,PSORXNS
;
S (DIV,PSOSITE)=$P(^PSRX(PSORXN,2),"^",9)
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"))
S PSOPAR=$G(^PS(59,DIV,1)),PSORFN=$G(^PS(59,DIV,"RF")),PSOITNF=0
S PSXSYS=+$O(^PSX(550,"C",""))_"^"_$G(PSOINST)_"^"_$G(PSOUTIL(4,SITE,.01,"E"))
I $G(PSXSYS) D
. K:($P($G(^PSX(550,+PSXSYS,0)),"^",2)'="A") PSXSYS
. I $$VERSION^XPDUTL("PSO")<7.0 K PSXSYS
S PSOSYS=$G(^PS(59.7,1,40.1))
;
I '$D(^PSRX(PSORXN,0))!($P(^(0),U)="")!('$D(^(2)))!($P(^("STA"),U)=13) D Q
. D ERR("Rx IEN "_PSORXN_" not in file (#52)/Incomplete/Deleted")
S PSORXN0=^PSRX(PSORXN,0),PSORXN2=^(2),PSORXN3=^(3),PSORXNS=^("STA")
S (DFN,PSODFN)=$P(PSORXN0,U,2),RXN=$P(PSORXN0,U),DRG=$P(PSORXN0,U,6)
D GET^PSOPTPST
I $G(PSOPTPST(2,PSODFN,.351))]"" D Q
. D ERR("Patient Died on "_PSOPTPST(2,PSODFN,.351))
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
. D ERR("Drug is inactive for Rx # "_RXN_" cannot be refilled")
I $G(PSOPTPST(2,PSODFN,.1))]"",'PSORFN D Q
. D ERR("Patient is an Inpatient on Ward "_PSOPTPST(2,PSODFN,.1))
I $G(PSOPTPST(2,PSODFN,148))="YES",'$P(PSORFN,U,2) D Q
. D ERR("Patient is in a Contract Nursing Home")
D CHKRF
;Original fill is Active/Parked, 0 refills, no labels previously printed ? ORIGINAL FILL
I $G(^PSRX(PSORXN,"PARK")),'$O(^PSRX(PSORXN,"L",0)),$P(^PSRX(PSORXN,0),"^",9)=0 S PSOITNF=1
Q:PSOITNF ;Quit if RX not refillable
;
;more checks
I $O(^PS(52.5,"B",PSORXN,0)),'$G(^PS(52.5,+$O(^PS(52.5,"B",PSORXN,0)),"P")) D Q
. D ERR("Rx is in suspense and cannot be refilled")
S PSOY=1+$$LSTRFL^PSOBPSU1(PSORXN)
I PSOY>$P(PSORXN0,U,9) D Q
. D ERR("Can't refill, no refills remaining")
S (PSOITF,PSOX("NUMBER"))=PSOY
S PSOX("RX0")=PSORXN0,PSOX("RX2")=PSORXN2,PSOX("RX3")=PSORXN3,PSOX("STA")=PSORXNS
S DRG=$P(PSORXN0,U,6)
N PSODEA,PSODAY,PSOCHECK
S PSODEA=$P($G(^PSDRUG(DRG,0)),U,3)
S PSODAY=$P(PSORXN0,U,8)
S PSOCHECK=$$DEACHK^PSOUTLA1(PSORXN,PSODEA,PSODAY)
I PSOCHECK=1 D ERR("Requested refill exceeds maximum allowable days supply for Rx.") Q ;*388
I PSOCHECK=2 D ERR("Current drug DEA/SPECIAL HANDLING code does not allow refills.") Q ;*388
D CHKDT Q:PSOITNF ;Quit if not refillable
;
; Titration Marked Rx
I $$TITRX^PSOUTL(PSORXN)="t" D Q
. D ERR("'Titration Rx' cannot be refilled.")
;
;ok to process refill
;S:'$P(PSOX("RX2"),U,2) $P(PSOX("RX2"),U,2)=DT
;I $O(^XUSEC("PSOAUTRF",0)),$$GET1^DIQ(59.7,1,40.16,"I"),$G(^PSRX($G(PSORXN),"PARK")),$L($G(PSOITNF)) N DA S DA=$G(PSORXN) D:DA EN^PSOPRKA
;Q:PSOITNF
D EN^PSOR52(.PSOX)
;add additional activity log comment to refill just added
I PSOITF,$D(^PSRX(PSORXN,1,PSOITF,0)) D
. I $G(PSOPARK)!($G(PSOFROM)]"") Q ; not being refilled from CPRS 441 PAPI
. N AL,DONE,PSOFDA
. S AL="",DONE=0
. F S AL=$O(^PSRX(PSORXN,"A",AL),-1) Q:'AL D Q:DONE
. . Q:$P(^PSRX(PSORXN,"A",AL,0),U,4)'=PSOITF
. . S PSOFDA(52.34,"+3,"_AL_","_PSORXN_",",.01)="CPRS Auto Refill"
. . D UPDATE^DIE("","PSOFDA")
. . S DONE=1
Q
;
CHKRF ;check precription if still refillable
S X2=-120,X1=DT D C^%DTC S PSODTCUT=X
D ^PSOBUILD
I '$G(PSOSD) D Q
. D ERR("This patient has no prescriptions")
S (PSOX,PSOY,PSOS)="",PSOX("STA")=PSORXNS
F S PSOS=$O(PSOSD(PSOS)) Q:PSOS="" F S PSOX=$O(PSOSD(PSOS,PSOX)) Q:PSOX']"" D
. I PSORXN=+PSOSD(PSOS,PSOX) S PSOY=PSOSD(PSOS,PSOX) I $P(PSOY,U,4)]"" D
. . D ERR("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,PSOB=$P(^DD(52,100,0),U,3)
. . . S PSOA=$F(PSOB,PSOA),PSOA=$P($E(PSOB,PSOA,999),";",1)
. . . D ERR(" Rx is in "_$P(PSOA,":",2)_" status")
. . . K PSOA,PSOB
. . I PSOREA["M" D ERR("Drug no longer used by Outpatient Pharmacy") Q
. . I PSOREA["B" D ERR("Narcotic Drug") Q
. . I PSOREA["C" D ERR("Non-Renewable Drug") Q
. . I PSOREA["D" D ERR("Non-Renewable Patient Status") Q
. . I PSOREA["E" D ERR("Non-Verified Rx") Q
. . I PSOREA["G",PSOREA'["B" D ERR("No more refills left")
I PSOY="" D ERR("Cannot refill, Rx is DC/Exp. Later Rx may exist") D
. S (PSOS,PSOX)="",PSOD=$P(^PSDRUG($P(PSORXN0,U,6),0),U)
. N ZRX S ZRX=""
. F S PSOS=$O(PSOSD(PSOS)) Q:PSOS="" D
. . F S PSOX=$O(PSOSD(PSOS,PSOX)) Q:PSOX="" D
. . . I PSOD=PSOX,+PSOSD(PSOS,PSOX) S ZRX=$P($G(^PSRX(+PSOSD(PSOS,PSOX),0)),U)
. D ERR(ZRX)
Q
;
CHKDT ;check date on this refill request
N X1,X2
S PSOX("IRXN")=PSORXN
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(PSORXN2,U,6) D NEXT
I PSOX("FILL DATE")<$P(PSORXN3,U,2) D SUSDATE^PSOUTIL(.PSOX)
I PSOX("FILL DATE")>PSOX("STOP DATE") D Q
. D ERR("Can't refill, Refill Date "_$$DSP(PSOX("FILL DATE")))
. D ERR("is past Expiration Date "_$$DSP(PSOX("STOP DATE")))
S PSOX("LAST REFILL DATE")=$P(PSORXN3,U,1)
I PSOX("LAST REFILL DATE"),PSOX("FILL DATE")=PSOX("LAST REFILL DATE") D Q
. D ERR("Can't refill, Fill Date already exists for "_$$DSP(PSOX("FILL DATE")))
I PSOX("LAST REFILL DATE"),PSOX("FILL DATE")<PSOX("LAST REFILL DATE") D Q
. D ERR("Can't refill, later Refill Date already exists for "_$$DSP(PSOX("LAST REFILL DATE")))
Q
;
NEXT ;
S PSOX1=$P(PSORXN2,U,2)
I '$O(^PSRX(PSORXN,1,0)) D Q
. S $P(PSORXN3,U)=PSOX1,X1=PSOX1 ;S:X1="" X1=DT
. S X2=$P(PSORXN0,U,8)-10\1
. D C^%DTC
. S:'$P(PSORXN3,U,8) $P(PSORXN3,U,2)=X K X
S PSOY2=0
F PSOY=0:0 S PSOY=$O(^PSRX(PSORXN,1,PSOY)) Q:'PSOY S PSOY1=PSOY,PSOY2=PSOY2+1
S PSOY=^PSRX(PSORXN,1,PSOY1,0)
S PSOX2=$P(PSOY,U)
S $P(PSORXN3,U)=PSOX2,X1=PSOX2
S X2=$P(PSORXN0,U,8)-10\1
D C^%DTC S PSOY3=X
S X1=PSOX1,X2=(PSOY2+1)*$P(PSORXN0,U,8)-10\1
D C^%DTC S PSOY4=X
S $P(PSORXN3,U,2)=$S(PSOY3<PSOY4:PSOY4,1:PSOY3)
K X,X1,X2,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)
;
ERR(TXT) ;Build error text array
; add TXT to end of last line in array, if will fit, else
; add it as a new last line and indented 3.
; and set error flag
N II S II=$O(PSOITMG(""),-1) S:'II II=1
S PSOITNF=1
I $L($G(PSOITMG(II)))+$L(TXT)>79 D
. S PSOITMG(II+1)=" "_TXT
E D
. S PSOITMG(II)=$G(PSOITMG(II))_" "_TXT
Q
;
MAILMSG(DFN,RXN,ERRTXT) ;send alert via mailman msg to PSOAUTRF key holders
N MDUZ,XMDUZ,XMTEXT,XMSUB,PTNAME,PTSSN,DIV,DIVN
D DEM^VADPT
S PTNAME=$P(VADM(1),"^"),PTSSN=$P($P(VADM(2),"^",2),"-",3) K VADM
S DIV=$$RXSITE^PSOBPSUT(RXN,0),DIVN=$P($G(^PS(59,DIV,0)),"^")
S MDUZ=0
F S MDUZ=$O(^XUSEC("PSOAUTRF",MDUZ)) Q:MDUZ'>0 S XMY(MDUZ)=""
S XMDUZ=.5,XMSUB=DIVN_" CPRS AUTO REFILL - Not Processed List"
S ERRTXT(.1)="CPRS requested an Outpatient refill, but was not allowed for the below reason:"
S ERRTXT(.2)=""
S ERRTXT(.3)=" Patient: "_PTNAME_" ("_PTSSN_")"
S ERRTXT(.4)=" Rx #: "_$$GET1^DIQ(52,RXN,.01)
S ERRTXT(.5)=" Drug: "_$$GET1^DIQ(52,RXN,6)
S ERRTXT(.6)=""
S XMTEXT="ERRTXT(" N DIFROM
D ^XMD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOATRFC 7858 printed Dec 13, 2024@02:24:32 Page 2
PSOATRFC ;BIR/MHA - Automate CPRS Refill request ;Jul 13, 2021@14:18:47
+1 ;;7.0;OUTPATIENT PHARMACY;**305,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 ;
REF(PSORXN,PSOITMG) ;process refill request
+1 NEW DFN,PSODFN,PSODTCUT,PSOITNS,PSOITDD,PSOITNF,PSOITF,DIV
+2 NEW PSOITP,PSOITR,PSOINST,PSOPAR,PSOPINST,PSOPRPAS,PSOPAR7,PSOPTPST
+3 NEW PSOSITE,PSOSNM,PSOSYS,PSORFN,PSOREA,PSOSTAT,PSOD,PSOS,DRG,DIVN
+4 NEW PSXSYS,RX,RX0,RXN,VA,ZZ,LC,XMY,PSORXN0,PSORXN2,PSORXN3,PSORXNS
+5 ;
+6 SET (DIV,PSOSITE)=$PIECE(^PSRX(PSORXN,2),"^",9)
+7 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
+8 SET PSOINST=$GET(PSOUTIL(4,SITE,99,"I"))
+9 SET PSOPAR=$GET(^PS(59,DIV,1))
SET PSORFN=$GET(^PS(59,DIV,"RF"))
SET PSOITNF=0
+10 SET PSXSYS=+$ORDER(^PSX(550,"C",""))_"^"_$GET(PSOINST)_"^"_$GET(PSOUTIL(4,SITE,.01,"E"))
+11 IF $GET(PSXSYS)
Begin DoDot:1
+12 if ($PIECE($GET(^PSX(550,+PSXSYS,0)),"^",2)'="A")
KILL PSXSYS
+13 IF $$VERSION^XPDUTL("PSO")<7.0
KILL PSXSYS
End DoDot:1
+14 SET PSOSYS=$GET(^PS(59.7,1,40.1))
+15 ;
+16 IF '$DATA(^PSRX(PSORXN,0))!($PIECE(^(0),U)="")!('$DATA(^(2)))!($PIECE(^("STA"),U)=13)
Begin DoDot:1
+17 DO ERR("Rx IEN "_PSORXN_" not in file (#52)/Incomplete/Deleted")
End DoDot:1
QUIT
+18 SET PSORXN0=^PSRX(PSORXN,0)
SET PSORXN2=^(2)
SET PSORXN3=^(3)
SET PSORXNS=^("STA")
+19 SET (DFN,PSODFN)=$PIECE(PSORXN0,U,2)
SET RXN=$PIECE(PSORXN0,U)
SET DRG=$PIECE(PSORXN0,U,6)
+20 DO GET^PSOPTPST
+21 IF $GET(PSOPTPST(2,PSODFN,.351))]""
Begin DoDot:1
+22 DO ERR("Patient Died on "_PSOPTPST(2,PSODFN,.351))
End DoDot:1
QUIT
+23 DO ICN^PSODPT(DFN)
+24 SET PSOLOUD=1
if $PIECE($GET(^PS(55,DFN,0)),U,6)'=2
DO EN^PSOHLUP(DFN)
KILL PSOLOUD
+25 IF '$PIECE(PSOPAR,U,11)
IF $GET(^PSDRUG(DRG,"I"))]""
IF DT>$GET(^("I"))
Begin DoDot:1
+26 DO ERR("Drug is inactive for Rx # "_RXN_" cannot be refilled")
End DoDot:1
QUIT
+27 IF $GET(PSOPTPST(2,PSODFN,.1))]""
IF 'PSORFN
Begin DoDot:1
+28 DO ERR("Patient is an Inpatient on Ward "_PSOPTPST(2,PSODFN,.1))
End DoDot:1
QUIT
+29 IF $GET(PSOPTPST(2,PSODFN,148))="YES"
IF '$PIECE(PSORFN,U,2)
Begin DoDot:1
+30 DO ERR("Patient is in a Contract Nursing Home")
End DoDot:1
QUIT
+31 DO CHKRF
+32 ;Original fill is Active/Parked, 0 refills, no labels previously printed ? ORIGINAL FILL
+33 IF $GET(^PSRX(PSORXN,"PARK"))
IF '$ORDER(^PSRX(PSORXN,"L",0))
IF $PIECE(^PSRX(PSORXN,0),"^",9)=0
SET PSOITNF=1
+34 ;Quit if RX not refillable
if PSOITNF
QUIT
+35 ;
+36 ;more checks
+37 IF $ORDER(^PS(52.5,"B",PSORXN,0))
IF '$GET(^PS(52.5,+$ORDER(^PS(52.5,"B",PSORXN,0)),"P"))
Begin DoDot:1
+38 DO ERR("Rx is in suspense and cannot be refilled")
End DoDot:1
QUIT
+39 SET PSOY=1+$$LSTRFL^PSOBPSU1(PSORXN)
+40 IF PSOY>$PIECE(PSORXN0,U,9)
Begin DoDot:1
+41 DO ERR("Can't refill, no refills remaining")
End DoDot:1
QUIT
+42 SET (PSOITF,PSOX("NUMBER"))=PSOY
+43 SET PSOX("RX0")=PSORXN0
SET PSOX("RX2")=PSORXN2
SET PSOX("RX3")=PSORXN3
SET PSOX("STA")=PSORXNS
+44 SET DRG=$PIECE(PSORXN0,U,6)
+45 NEW PSODEA,PSODAY,PSOCHECK
+46 SET PSODEA=$PIECE($GET(^PSDRUG(DRG,0)),U,3)
+47 SET PSODAY=$PIECE(PSORXN0,U,8)
+48 SET PSOCHECK=$$DEACHK^PSOUTLA1(PSORXN,PSODEA,PSODAY)
+49 ;*388
IF PSOCHECK=1
DO ERR("Requested refill exceeds maximum allowable days supply for Rx.")
QUIT
+50 ;*388
IF PSOCHECK=2
DO ERR("Current drug DEA/SPECIAL HANDLING code does not allow refills.")
QUIT
+51 ;Quit if not refillable
DO CHKDT
if PSOITNF
QUIT
+52 ;
+53 ; Titration Marked Rx
+54 IF $$TITRX^PSOUTL(PSORXN)="t"
Begin DoDot:1
+55 DO ERR("'Titration Rx' cannot be refilled.")
End DoDot:1
QUIT
+56 ;
+57 ;ok to process refill
+58 ;S:'$P(PSOX("RX2"),U,2) $P(PSOX("RX2"),U,2)=DT
+59 ;I $O(^XUSEC("PSOAUTRF",0)),$$GET1^DIQ(59.7,1,40.16,"I"),$G(^PSRX($G(PSORXN),"PARK")),$L($G(PSOITNF)) N DA S DA=$G(PSORXN) D:DA EN^PSOPRKA
+60 ;Q:PSOITNF
+61 DO EN^PSOR52(.PSOX)
+62 ;add additional activity log comment to refill just added
+63 IF PSOITF
IF $DATA(^PSRX(PSORXN,1,PSOITF,0))
Begin DoDot:1
+64 ; not being refilled from CPRS 441 PAPI
IF $GET(PSOPARK)!($GET(PSOFROM)]"")
QUIT
+65 NEW AL,DONE,PSOFDA
+66 SET AL=""
SET DONE=0
+67 FOR
SET AL=$ORDER(^PSRX(PSORXN,"A",AL),-1)
if 'AL
QUIT
Begin DoDot:2
+68 if $PIECE(^PSRX(PSORXN,"A",AL,0),U,4)'=PSOITF
QUIT
+69 SET PSOFDA(52.34,"+3,"_AL_","_PSORXN_",",.01)="CPRS Auto Refill"
+70 DO UPDATE^DIE("","PSOFDA")
+71 SET DONE=1
End DoDot:2
if DONE
QUIT
End DoDot:1
+72 QUIT
+73 ;
CHKRF ;check precription if still refillable
+1 SET X2=-120
SET X1=DT
DO C^%DTC
SET PSODTCUT=X
+2 DO ^PSOBUILD
+3 IF '$GET(PSOSD)
Begin DoDot:1
+4 DO ERR("This patient has no prescriptions")
End DoDot:1
QUIT
+5 SET (PSOX,PSOY,PSOS)=""
SET PSOX("STA")=PSORXNS
+6 FOR
SET PSOS=$ORDER(PSOSD(PSOS))
if PSOS=""
QUIT
FOR
SET PSOX=$ORDER(PSOSD(PSOS,PSOX))
if PSOX']""
QUIT
Begin DoDot:1
+7 IF PSORXN=+PSOSD(PSOS,PSOX)
SET PSOY=PSOSD(PSOS,PSOX)
IF $PIECE(PSOY,U,4)]""
Begin DoDot:2
+8 DO ERR("Cannot refill Rx # "_RXN)
+9 SET PSOREA=$PIECE(PSOY,U,4)
SET PSOSTAT=PSOX("STA")
+10 IF PSOREA["Z"
if PSOSTAT=4
SET PSOSTAT=1
Begin DoDot:3
+11 SET PSOA=";"_PSOSTAT
SET PSOB=$PIECE(^DD(52,100,0),U,3)
+12 SET PSOA=$FIND(PSOB,PSOA)
SET PSOA=$PIECE($EXTRACT(PSOB,PSOA,999),";",1)
+13 DO ERR(" Rx is in "_$PIECE(PSOA,":",2)_" status")
+14 KILL PSOA,PSOB
End DoDot:3
QUIT
+15 IF PSOREA["M"
DO ERR("Drug no longer used by Outpatient Pharmacy")
QUIT
+16 IF PSOREA["B"
DO ERR("Narcotic Drug")
QUIT
+17 IF PSOREA["C"
DO ERR("Non-Renewable Drug")
QUIT
+18 IF PSOREA["D"
DO ERR("Non-Renewable Patient Status")
QUIT
+19 IF PSOREA["E"
DO ERR("Non-Verified Rx")
QUIT
+20 IF PSOREA["G"
IF PSOREA'["B"
DO ERR("No more refills left")
End DoDot:2
End DoDot:1
+21 IF PSOY=""
DO ERR("Cannot refill, Rx is DC/Exp. Later Rx may exist")
Begin DoDot:1
+22 SET (PSOS,PSOX)=""
SET PSOD=$PIECE(^PSDRUG($PIECE(PSORXN0,U,6),0),U)
+23 NEW ZRX
SET ZRX=""
+24 FOR
SET PSOS=$ORDER(PSOSD(PSOS))
if PSOS=""
QUIT
Begin DoDot:2
+25 FOR
SET PSOX=$ORDER(PSOSD(PSOS,PSOX))
if PSOX=""
QUIT
Begin DoDot:3
+26 IF PSOD=PSOX
IF +PSOSD(PSOS,PSOX)
SET ZRX=$PIECE($GET(^PSRX(+PSOSD(PSOS,PSOX),0)),U)
End DoDot:3
End DoDot:2
+27 DO ERR(ZRX)
End DoDot:1
+28 QUIT
+29 ;
CHKDT ;check date on this refill request
+1 NEW X1,X2
+2 SET PSOX("IRXN")=PSORXN
+3 SET PSOX("MAIL/WINDOW")="M"
SET PSOX("FLD")=2
SET PSOX("QS")="S"
+4 SET PSOX("FIELD")=0
SET (PSORX("FILL DATE"),PSOX("FILL DATE"))=DT
SET PSOX("FLD")=1
SET X1=DT
SET X2=-180
+5 DO C^%DTC
SET PSOX("ISSUE DATE")=X
SET PSOX("CLERK CODE")=DUZ
+6 SET PSOX("STOP DATE")=$PIECE(PSORXN2,U,6)
DO NEXT
+7 IF PSOX("FILL DATE")<$PIECE(PSORXN3,U,2)
DO SUSDATE^PSOUTIL(.PSOX)
+8 IF PSOX("FILL DATE")>PSOX("STOP DATE")
Begin DoDot:1
+9 DO ERR("Can't refill, Refill Date "_$$DSP(PSOX("FILL DATE")))
+10 DO ERR("is past Expiration Date "_$$DSP(PSOX("STOP DATE")))
End DoDot:1
QUIT
+11 SET PSOX("LAST REFILL DATE")=$PIECE(PSORXN3,U,1)
+12 IF PSOX("LAST REFILL DATE")
IF PSOX("FILL DATE")=PSOX("LAST REFILL DATE")
Begin DoDot:1
+13 DO ERR("Can't refill, Fill Date already exists for "_$$DSP(PSOX("FILL DATE")))
End DoDot:1
QUIT
+14 IF PSOX("LAST REFILL DATE")
IF PSOX("FILL DATE")<PSOX("LAST REFILL DATE")
Begin DoDot:1
+15 DO ERR("Can't refill, later Refill Date already exists for "_$$DSP(PSOX("LAST REFILL DATE")))
End DoDot:1
QUIT
+16 QUIT
+17 ;
NEXT ;
+1 SET PSOX1=$PIECE(PSORXN2,U,2)
+2 IF '$ORDER(^PSRX(PSORXN,1,0))
Begin DoDot:1
+3 ;S:X1="" X1=DT
SET $PIECE(PSORXN3,U)=PSOX1
SET X1=PSOX1
+4 SET X2=$PIECE(PSORXN0,U,8)-10\1
+5 DO C^%DTC
+6 if '$PIECE(PSORXN3,U,8)
SET $PIECE(PSORXN3,U,2)=X
KILL X
End DoDot:1
QUIT
+7 SET PSOY2=0
+8 FOR PSOY=0:0
SET PSOY=$ORDER(^PSRX(PSORXN,1,PSOY))
if 'PSOY
QUIT
SET PSOY1=PSOY
SET PSOY2=PSOY2+1
+9 SET PSOY=^PSRX(PSORXN,1,PSOY1,0)
+10 SET PSOX2=$PIECE(PSOY,U)
+11 SET $PIECE(PSORXN3,U)=PSOX2
SET X1=PSOX2
+12 SET X2=$PIECE(PSORXN0,U,8)-10\1
+13 DO C^%DTC
SET PSOY3=X
+14 SET X1=PSOX1
SET X2=(PSOY2+1)*$PIECE(PSORXN0,U,8)-10\1
+15 DO C^%DTC
SET PSOY4=X
+16 SET $PIECE(PSORXN3,U,2)=$SELECT(PSOY3<PSOY4:PSOY4,1:PSOY3)
+17 KILL X,X1,X2,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 ;
ERR(TXT) ;Build error text array
+1 ; add TXT to end of last line in array, if will fit, else
+2 ; add it as a new last line and indented 3.
+3 ; and set error flag
+4 NEW II
SET II=$ORDER(PSOITMG(""),-1)
if 'II
SET II=1
+5 SET PSOITNF=1
+6 IF $LENGTH($GET(PSOITMG(II)))+$LENGTH(TXT)>79
Begin DoDot:1
+7 SET PSOITMG(II+1)=" "_TXT
End DoDot:1
+8 IF '$TEST
Begin DoDot:1
+9 SET PSOITMG(II)=$GET(PSOITMG(II))_" "_TXT
End DoDot:1
+10 QUIT
+11 ;
MAILMSG(DFN,RXN,ERRTXT) ;send alert via mailman msg to PSOAUTRF key holders
+1 NEW MDUZ,XMDUZ,XMTEXT,XMSUB,PTNAME,PTSSN,DIV,DIVN
+2 DO DEM^VADPT
+3 SET PTNAME=$PIECE(VADM(1),"^")
SET PTSSN=$PIECE($PIECE(VADM(2),"^",2),"-",3)
KILL VADM
+4 SET DIV=$$RXSITE^PSOBPSUT(RXN,0)
SET DIVN=$PIECE($GET(^PS(59,DIV,0)),"^")
+5 SET MDUZ=0
+6 FOR
SET MDUZ=$ORDER(^XUSEC("PSOAUTRF",MDUZ))
if MDUZ'>0
QUIT
SET XMY(MDUZ)=""
+7 SET XMDUZ=.5
SET XMSUB=DIVN_" CPRS AUTO REFILL - Not Processed List"
+8 SET ERRTXT(.1)="CPRS requested an Outpatient refill, but was not allowed for the below reason:"
+9 SET ERRTXT(.2)=""
+10 SET ERRTXT(.3)=" Patient: "_PTNAME_" ("_PTSSN_")"
+11 SET ERRTXT(.4)=" Rx #: "_$$GET1^DIQ(52,RXN,.01)
+12 SET ERRTXT(.5)=" Drug: "_$$GET1^DIQ(52,RXN,6)
+13 SET ERRTXT(.6)=""
+14 SET XMTEXT="ERRTXT("
NEW DIFROM
+15 DO ^XMD
+16 QUIT
