PSOVEXRX ;BIRM/KML - PHARMACY TELEPHONE REFILLS ; July 31, 2023@18:05:28
;;7.0;OUTPATIENT PHARMACY;**653,677,712**;Dec 1997;Build 20
;
; Reference to PSOL^PSSLOCK,PSOUL^PSSLOCK in ICR #2789
; Reference to RENEW^ORAREN in ICR #5498
;
N QUIT
S QUIT=0
D PSOBLD^PSOVEXR1 Q:QUIT
D START Q:QUIT
D SUMM Q:QUIT
D SETVEN^PSOVEXR1
I 'PSOCNT,PRINT W !,"No telephone refills were processed."
Q
;
START ;
N PSOANS,PSOANS2,PSODFN,PSONO,PSONRF,PSONRFLG,PSOPAR,PSOPROVP,PSOPTRAD,PSOREFLG,PSORENEW,PSORXEN,PSORXIEN,PSOREN,PSORFY,PSOVX,PSOXFLAG
N PSORXN,PSOSITE,PSOISITE,PSOVEXI,PSOCNT,PSOCNT1,PSORSULT,PRINT,LN,PSOTILDE,PSOVEXFL,PSO648,DIR,PSOBBC,PSOBBC1,PSORX,PSOTTREN,PSOTOTF,PSOKPK
K ^TMP($J,"ORAREN E"),^TMP($J,"ORAREN OC"),^TMP("PSOFILLED",$J)
S (PSOCNT1,PSONRF,PSONRFLG,PSORFY,PSOTTREN,PSOTOTF)=0
S PSOVX=0 F S PSOVX=$O(^PS(59,PSOVX)) Q:'PSOVX I $P($G(^PS(59,PSOVX,"I")),"^"),DT>$P($G(^("I")),"^") S PSOVEXI(PSOVX)=""
I $O(PSOVEXI(0)) W !,"Looking for refill requests for inactive Outpatient divisions..."
S PSOVX=0 F S PSOVX=$O(PSOVEXI(PSOVX)) Q:'PSOVX D
. S PSORXN=0 F S PSORXN=$O(^PS(52.444,"C",PSOVX,PSORXN)) Q:'PSORXN D
. . Q:($P(^PS(52.444,PSORXN,0),U,4)) ;Quit if already date processed exists
. . S PSORXIEN=$P(^PS(52.444,PSORXN,0),"^")
. . S PSOISITE=$P($G(^PSRX(+PSORXIEN,2)),"^",9) Q:$G(PSOVEXI(+$G(PSOISITE)))
. . I PSOISITE,$D(PSOVEXI(PSOISITE)),$P(^PS(52.444,PSORXN,0),"^",4)="" S PSOVEXI(PSOVX)=1,PSOVEXFL=1
I '$G(PSOVEXFL),$O(PSOVEXI(0)) W ".none found.",!
I $G(PSOVEXFL) W !!,"The following Inactive Outpatient sites have refill requests:",! F PSOVX=0:0 S PSOVX=$O(PSOVEXI(PSOVX)) Q:'PSOVX I $G(PSOVEXI(PSOVX)) W !?5,$P($G(^PS(59,+$G(PSOVX),0)),"^")
I $G(PSOVEXFL) W ! S DIR(0)="E",DIR("A")="Press Return to Continue, '^' to exit",DIR("T")=DTIME D ^DIR W ! I Y'=1 S QUIT=1 Q
D:'$D(PSOPAR) ^PSOLSET I $G(PSOQUIT)!'$D(PSOPAR) S QUIT=1 Q
W !!!?20,"Division: "_$P(^PS(59,PSOSITE,0),"^"),!!
S PSOBBC1("FROM")="REFILL",PSOBBC("QFLG")=0,PSOBBC("DFLG")=0
I '$D(^PS(52.444,"C",PSOSITE)) S PSOANS="N" W !!,"There are no telephone refills to process for the selected division." S QUIT=1 Q
D ASK^PSOBBC W:PSOBBC("QFLG")=1 !,"No telephone refills were processed." I PSOBBC("QFLG")=1 S QUIT=1 Q
PSOX W ! S DIR("A")="Process telephone refill requests at this time",DIR("B")="YES",DIR(0)="Y",DIR("T")=DTIME D ^DIR K DIR S PSOANS="N" I $G(DIRUT)!(Y=0) S QUIT=1 W !?7,$C(7),"No telephone refills were processed." Q
S PSORXIEN="" I Y=1 S PSOANS="Y"
S PSOPTRAD=$$GET1^DIQ(59,PSOSITE,4.2) ;parameter from 59 for all divisions default prompt answer
S PSOANS2="S" ; initialize the answer to the processing all divisions prompt
I PSOANS["Y",$$GET1^DIQ(59.7,1,"INTERDIVISIONAL PROCESSING","I") D I $G(DIRUT) S PSOANS="N" S QUIT=1 W !?7,$C(7),"No telephone refills were processed." Q
. S DIR("A")="Process telephone refills for all divisions",DIR("B")=PSOPTRAD,DIR(0)="Y",DIR("T")=DTIME
. W !
. S DIR("?",1)="Enter 'YES' to process all division refill requests."
. S DIR("?",2)="Enter 'NO' to only process refill request for the division you selected when you logged on."
. S DIR("?")=" "
. D ^DIR K DIR S:Y=1 PSOANS2="M"
I PSOANS2["S" S PSONO=$D(^PS(52.444,"C",PSOSITE)) I '$G(PSONO) W !,"There are no requests for your selected division." Q
S PSOCNT1=10 ; use to indicate first time through for mail msg build
S $P(LN,"-",80)="",PSOCNT=0
PSO6 I PSOANS["Y",$G(PSORXIEN) S PSORXEN=0,PSORXEN=$O(^PS(52.444,"B",PSORXIEN,PSORXEN)) D PSO5 ;MARK PROCESSED NODES
I PSOANS="N" S PSORX=PSORXIEN D ULK G END
D PSO3 I $G(PSOANS)="N" S PSORX=PSORXIEN D ULK G END
I 'PSOSITE W !?7,$C(7),$C(7),$C(7),"Not from this institution.",! S PSORX=PSORXIEN D ULK G PSO6
I $L(PSORENEW) S PSORENEW="" G PSO6
S (PSOBBC("IRXN"),PSOBBC("OIRXN"))=PSORXIEN
I $D(^PSRX(PSOBBC("IRXN"),0))']"" W !,$C(7),"Rx data is not on file!",! S PSORX=PSORXIEN D ULK G PSO6
I $P($G(^PSRX(PSOBBC("IRXN"),"STA")),"^")=13 W !,$C(7),"Rx has already been deleted." S PSORX=PSORXIEN D ULK G PSO6
I $G(PSOBBC("DONE"))[PSOBBC("IRXN")_"," W !,$C(7),"Rx has already been entered." S PSORX=PSORXIEN D ULK G PSO6
K X,Y D:PSOBBC("QFLG") PROCESSX^PSOBBC
S PSOSELSE=0 I $G(PSODFN)'=$P(^PSRX(PSOBBC("IRXN"),0),"^",2) S PSOSELSE=1 W !,LN D PT^PSOBBC I $G(PSOBBC("DFLG")) K PSOSELSE S PSORX=PSORXIEN D ULK G PSO6
I '$G(PSOSELSE) W !,LN D PTC^PSOBBC I $G(PSOBBC("DFLG")) K PSOSELSE S PSORX=PSORXIEN D ULK G PSO6
K PSOSELSE D PROFILE^PSORX1
;p677 handle multi division
;S PSOBBC("DONE")=PSOBBC("IRXN")_"," D REFILL^PSOBBC
S PSOKPK=1
I '$P($G(PSOSYS),"^",2) D REFILL^PSOBBC I 1
E D
. I PSOSITE'=$P(^PSRX(PSORXIEN,2),U,9) S PSOBBC("PSOVEXRX")=PSOSITE N PSOSITE S PSOSITE=$P(^PSRX(PSORXIEN,2),U,9)
. D REFILL^PSOBBC
. K PSOBBC("PSOVEXRX")
S PSOBBC("DONE")=PSOBBC("IRXN")_","
I $$TITRX^PSOUTL(PSOBBC("IRXN"))="t",'$G(UNPARK) S PSOBBC("DFLG")=1
S PSORX=PSORXIEN D ULK G PSO6
;
PSO3 ; avoid skipping renewal requests.
N PSOPP
K PSOBBC("IRXN"),PSOXFLAG,PSOPP S:'$G(PSORXIEN) PSORXIEN=0 F S PSORXIEN=$O(^PS(52.444,"B",PSORXIEN)) D Q:PSOANS="N"!($G(PSOXFLAG))
. I PSORXIEN="" S PSOANS="N" Q
. I PSOANS2["S",$D(^PSRX(PSORXIEN,0)),PSOSITE'=$P(^PSRX(PSORXIEN,2),"^",9) Q
. S PSORXEN=0 F S PSORXEN=$O(^PS(52.444,"B",PSORXIEN,PSORXEN)) Q:'PSORXEN D
. . I $P(^PS(52.444,PSORXEN,0),U,4) S ^TMP("PSOFILLED",$J,PSORXIEN)=""
. . Q:($P(^PS(52.444,PSORXEN,0),U,4)) ;Quit if date processed exists
. . S PSOCNT=PSOCNT+1
. . S PSO648=0,PSOREN=$P(^PS(52.444,PSORXEN,0),U,4,9) I PSOREN]"" D BFDRNCHK
. . ;CANNOT PROCESS RENEWAL ENTRIES CONTAINING TILDE CHARACTER (~) IN THE FREE TEXT DOSAGE FIELD
. . I ($P($G(PSOREN),U,3)]"") S PSOTILDE=$$TILDECHK^PSOVEXR1(PSORXIEN,PSORXEN) I +PSOTILDE D PSO7(PSORXIEN,PSOTILDE) K PSOTILDE Q:'$G(DUOUT) I $G(DUOUT) S PSOANS="N" Q
. . I '$D(^PSRX(PSORXIEN,0)),PSO648=1 D PSO5 Q ;SKIPS ERRONEOUS ENTRIES
. . I PSOANS["Y" Q:PSO648=1 ;SKIPS ENTRIES ALREADY PROCESSED AND FORMATS VARIABLE X (BFD/648 LINE)
. . D RENEWCHK I PSORENEW]"" S PSOXFLAG=1 Q
. . I PSORXIEN S PSORX=PSORXIEN D PSOL^PSSLOCK(PSORX) I '$G(PSOMSG) K PSORX,PSOMSG Q
. . K PSOMSG S PSOXFLAG=1
I 'PSOCNT W !!,"There are NO telephone refills to process."
Q
; -----------------------------------------------------------------------------------
PSO5 ; Mark the node as processed.
K FDA,IENS
S PSORXIEN=$P(^PS(52.444,PSORXEN,0),U)
I PSOREFLG=0 S IENS=PSORXEN_",",FDA(52.444,IENS,3)=DT D FILE^DIE(,"FDA","PSOERR") D ;marks node as processed
. I $G(PSOKPK)>1 S PSOKPK=1 Q
. I $G(PSOBBC("DFLG")) D PSO12 ;FLAGS UNSUCCESSFUL ATTEMPTS TO REFILL.
I PSONRFLG=0,(PSOREFLG=0) S PSORFY=PSORFY+1
S PSONRFLG=0
I '$G(PSOBBC("DFLG")),PSORSULT=1 W !,LN,!,"Prescription: RX # "_$P(^PSRX(PSORXIEN,0),U)_" Processed",!
Q
;
PSO7(PSORXIEN,PSOTILDE) ; Add skipped prescriptions due to tilde error to the report
; input = PSORXIEN - ien of RX in PRESCRIPTION file (#52)
; input = PSOTILDE - string representing the results of Tilde check
; first piece = 1 or 0; where 1 means it's an RX with a Tilde in the dosage form
; second piece = 1 or 0; where 1 means it's a controlled substance RX
;
N LAST,PSORET,TXT,XX
; Tilde RX is a controlled substance
I $P(PSOTILDE,"^",2) D G PSO7X
. S LAST=0 I $D(^TMP($J,"ORAREN E")) S LAST=$O(^TMP($J,"ORAREN E",9999),-1)
. I LAST>0 S LAST=LAST+1,^TMP($J,"ORAREN E",LAST,0)=" "
. S (TXT(1),^TMP($J,"ORAREN E",LAST+1,0))="RX # "_$P(^PSRX(PSORXIEN,0),U)
. S (TXT(2),^TMP($J,"ORAREN E",LAST+2,0))="This controlled substance prescription cannot generate a notification to"
. S (TXT(3),^TMP($J,"ORAREN E",LAST+3,0))="the provider because there is a tilde (~) character in the dosage field. "
. S (TXT(4),^TMP($J,"ORAREN E",LAST+4,0))="Using CPRS, flag the requested order and ask the provider to correct"
. S (TXT(5),^TMP($J,"ORAREN E",LAST+5,0))="the order by removing the tilde (~) from the free text dosage using"
. S (TXT(6),^TMP($J,"ORAREN E",LAST+6,0))="Change or Copy to New Order. When the corrected order is digitally"
. S (TXT(7),^TMP($J,"ORAREN E",LAST+7,0))="signed, a Pending order is created for the pharmacy to finish."
. S (TXT(8),^TMP($J,"ORAREN E",LAST+8,0))=""
. W !,LN
. S XX=0 F S XX=$O(TXT(XX)) Q:XX="" W !,TXT(XX)
. W !
; Tilde RX not a controlled substance
S LAST=0 I $D(^TMP($J,"ORAREN E")) S LAST=$O(^TMP($J,"ORAREN E",9999),-1)
I LAST>0 S LAST=LAST+1,^TMP($J,"ORAREN E",LAST,0)=" "
S (TXT(1),^TMP($J,"ORAREN E",LAST+1,0))="RX # "_$P(^PSRX(PSORXIEN,0),U)
S (TXT(2),^TMP($J,"ORAREN E",LAST+2,0))="This prescription cannot be renewed because there is a tilde (~)"
S (TXT(3),^TMP($J,"ORAREN E",LAST+3,0))="character in the dosage field. Using CPRS, flag the requested"
S (TXT(4),^TMP($J,"ORAREN E",LAST+4,0))="order and ask the provider to remove the tilde (~) from the free"
S (TXT(5),^TMP($J,"ORAREN E",LAST+5,0))="text dosage when Renewing. After the corrected order is digitally"
S (TXT(6),^TMP($J,"ORAREN E",LAST+6,0))="signed, a Pending order is created for the pharmacy to finish."
S (TXT(7),^TMP($J,"ORAREN E",LAST+7,0))=" "
W !,LN
S XX=0 F S XX=$O(TXT(XX)) Q:XX="" W !,TXT(XX)
PSO7X ;
S PSOTOTF=$G(PSOTOTF)+1
W ! S DIR("A")="Enter <RETURN> to continue.",DIR(0)="FO",DIR("T")=DTIME
S DIR("?")=" ",DIR("?",1)="Answering ""^"" will abort processing and the remaining refills will not"
S DIR("?",2)="be processed."
D ^DIR K DIR
Q
;
PSO12 ; refill not processed.
K FDA,IENS
S PSONRF=PSONRF+1,PSONRFLG=1
S IENS=PSORXEN_"," ;NOTE THE IENS MUST HAVE A FINAL COMMA ADDED TO THE ENTRY NUMBER.
S FDA(52.444,IENS,4)="NOT FILLED" D FILE^DIE(,"FDA","PSOERR")
W !,"Prescription REFILL, RX # "_$P(^PSRX(PSORXIEN,0),U)_", was not processed. ",!," PLEASE TAKE APPROPRIATE ACTION."
S DIR("?",1)="Answering YES will continue to process the remaining Telephone Refill"
S DIR("?",2)="Requests. "
S DIR("?",3)=""
S DIR("?",4)="Answering NO will abort processing and the remaining refills will not be"
S DIR("?")="processed. The option will need to be run again to continue processing."
W ! S DIR("A")="Do you wish to continue processing the remaining refill requests",DIR("B")="YES",DIR(0)="Y",DIR("T")=DTIME D ^DIR
W ! K DIR I Y'=1 S PSOANS="N"
Q
END D PROCESSX^PSOBBC
K XMY N XMDUZ,XMSUB,XMTEXT,XMT
S XMDUZ="AUTO,RENEWAL",XMY(DUZ)="",XMY("G.AUTORENEWAL")="",XMSUB=$S($G(PSOANS2)["S":$$GET1^DIQ(59,PSOSITE,.01)_" ",1:"")_"REFILL TOTALS",XMTEXT="XMT("
S XMT(1,0)="Refills Processed: "_PSORFY,XMT(2,0)="Refills 'Not Processed': "_PSONRF
S XMT(3,0)=" ",XMT(4,0)="Renewals sent to provider: "_PSOTTREN
S XMT(5,0)="Renewals not sent to provider: "_PSOTOTF
D ^XMD
I $D(^TMP($J)) K XMY N XMDUZ,XMSUB,XMTEXT D
. S XMY(DUZ)=""
. I $D(^TMP($J,"ORAREN E")) S XMDUZ="AUTO,RENEWAL",XMY("G.AUTORENEWAL")="",XMSUB=$S($G(PSOANS2)["S":$$GET1^DIQ(59,PSOSITE,.01)_" ",1:"")_"RENEWAL REQUESTS NOT SENT TO PROVIDERS",XMTEXT="^TMP("_$J_",""ORAREN E""," D ^XMD
. I $D(^TMP($J,"ORAREN OC")) S XMDUZ="AUTO,RENEWAL",XMY("G.AUTORENEWAL")="",XMSUB=$S($G(PSOANS2)["S":$$GET1^DIQ(59,PSOSITE,.01)_" ",1:"")_"RENEWAL REQUESTS WITH ORDER CHECKS",XMTEXT="^TMP("_$J_",""ORAREN OC""," D ^XMD
I $P($G(^PS(59,+$G(PSOSITE),"I")),"^"),DT>$P($G(^("I")),"^") D FINAL^PSOLSET W !!,"Your Outpatient Site parameters have been deleted because you selected an",!,"inactive Outpatient Site!",!
K DIR,DIRUT,DUOUT,PSOBBC,PSOBBC1
Q
ULK ; unlock a record.
N SAVE
I '$G(PSORX) Q
D PSOUL^PSSLOCK(PSORX)
M SAVE=PSORX
K PSORX
S PSORX("FILL DATE")=$G(SAVE("FILL DATE")),PSORX("MAIL/WINDOW")=$G(SAVE("MAIL/WINDOW")),PSORX("METHOD OF PICK-UP")=$G(SAVE("METHOD OF PICK-UP"))
Q
; -----------------------------------------------------------------------------------
RENEWCHK ; Checks ^PS(52.444 node for renewal information
K FDA,IENS
S (PSOREFLG,PSORSULT)=0
S PSORENEW=$P(PSOREN,"^",3),PSOPROVP=$P(PSOREN,"^",6)
I PSORENEW="U"!(PSORENEW="I")!(PSORENEW="N") D
. S PSORXIEN=+$P(^PS(52.444,PSORXEN,0),U),PSODFN=+$P(^PS(52.444,PSORXEN,0),U,3)
. D RENEW^ORAREN(.PSORSULT,PSODFN,PSORXIEN,PSOPROVP,PSORENEW) ;ICR 5498
. S PSOREFLG=1
. S IENS=PSORXEN_",",FDA(52.444,IENS,3)=DT D FILE^DIE(,"FDA","PSOERR") ;marks node as processed
. S IENS=PSORXEN_",",FDA(52.444,IENS,6)=PSORSULT D FILE^DIE(,"FDA","PSOERR") ;marks the result from RENEW^ORAREN processing
. I PSORSULT=0 S PSOCNT1=PSOCNT1+1
. I PSORSULT'=1 S PSOTOTF=PSOTOTF+1 W !,LN,!,$C(7),"Prescription Renewal Request, RX # "_$P(^PSRX(PSORXIEN,0),U)_", was not sent to the provider. ",!," PLEASE TAKE APPROPRIATE ACTION."
. I PSORSULT=1 S PSOTTREN=PSOTTREN+1
. Q
Q
BFDRNCHK ; There is data in global - is it date or renewal request
;"if there is something in the Date piece S PSO648=1 to stop processing"
I $P(PSOREN,"^",1)]"" S PSO648=1
;if there are more than just piece 1 but the
I $P(PSOREN,"^",1)']"" S PSO648=0
;"if PSO648 is 0 then no date but renewal"
Q
;
SUMM ; display summary of refills processed
S DIR("A")="Display the full summary of individual orders processed"
s DIR("B")="NO",DIR(0)="Y"
S DIR("?",1)="Enter 'YES' to display the summary of orders processed in this session."
S DIR("?",2)="Enter 'NO' to not display the summary."
S DIR("?")=" "
D ^DIR K DIR
I $G(DIRUT) S QUIT=1 Q
S PRINT=$S(+Y=1:1,1:0)
I PRINT W !!!,"TELEPHONE REFILL/RENEW SUMMARY",!!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOVEXRX 13472 printed Dec 13, 2024@02:36:24 Page 2
PSOVEXRX ;BIRM/KML - PHARMACY TELEPHONE REFILLS ; July 31, 2023@18:05:28
+1 ;;7.0;OUTPATIENT PHARMACY;**653,677,712**;Dec 1997;Build 20
+2 ;
+3 ; Reference to PSOL^PSSLOCK,PSOUL^PSSLOCK in ICR #2789
+4 ; Reference to RENEW^ORAREN in ICR #5498
+5 ;
+6 NEW QUIT
+7 SET QUIT=0
+8 DO PSOBLD^PSOVEXR1
if QUIT
QUIT
+9 DO START
if QUIT
QUIT
+10 DO SUMM
if QUIT
QUIT
+11 DO SETVEN^PSOVEXR1
+12 IF 'PSOCNT
IF PRINT
WRITE !,"No telephone refills were processed."
+13 QUIT
+14 ;
START ;
+1 NEW PSOANS,PSOANS2,PSODFN,PSONO,PSONRF,PSONRFLG,PSOPAR,PSOPROVP,PSOPTRAD,PSOREFLG,PSORENEW,PSORXEN,PSORXIEN,PSOREN,PSORFY,PSOVX,PSOXFLAG
+2 NEW PSORXN,PSOSITE,PSOISITE,PSOVEXI,PSOCNT,PSOCNT1,PSORSULT,PRINT,LN,PSOTILDE,PSOVEXFL,PSO648,DIR,PSOBBC,PSOBBC1,PSORX,PSOTTREN,PSOTOTF,PSOKPK
+3 KILL ^TMP($JOB,"ORAREN E"),^TMP($JOB,"ORAREN OC"),^TMP("PSOFILLED",$JOB)
+4 SET (PSOCNT1,PSONRF,PSONRFLG,PSORFY,PSOTTREN,PSOTOTF)=0
+5 SET PSOVX=0
FOR
SET PSOVX=$ORDER(^PS(59,PSOVX))
if 'PSOVX
QUIT
IF $PIECE($GET(^PS(59,PSOVX,"I")),"^")
IF DT>$PIECE($GET(^("I")),"^")
SET PSOVEXI(PSOVX)=""
+6 IF $ORDER(PSOVEXI(0))
WRITE !,"Looking for refill requests for inactive Outpatient divisions..."
+7 SET PSOVX=0
FOR
SET PSOVX=$ORDER(PSOVEXI(PSOVX))
if 'PSOVX
QUIT
Begin DoDot:1
+8 SET PSORXN=0
FOR
SET PSORXN=$ORDER(^PS(52.444,"C",PSOVX,PSORXN))
if 'PSORXN
QUIT
Begin DoDot:2
+9 ;Quit if already date processed exists
if ($PIECE(^PS(52.444,PSORXN,0),U,4))
QUIT
+10 SET PSORXIEN=$PIECE(^PS(52.444,PSORXN,0),"^")
+11 SET PSOISITE=$PIECE($GET(^PSRX(+PSORXIEN,2)),"^",9)
if $GET(PSOVEXI(+$GET(PSOISITE)))
QUIT
+12 IF PSOISITE
IF $DATA(PSOVEXI(PSOISITE))
IF $PIECE(^PS(52.444,PSORXN,0),"^",4)=""
SET PSOVEXI(PSOVX)=1
SET PSOVEXFL=1
End DoDot:2
End DoDot:1
+13 IF '$GET(PSOVEXFL)
IF $ORDER(PSOVEXI(0))
WRITE ".none found.",!
+14 IF $GET(PSOVEXFL)
WRITE !!,"The following Inactive Outpatient sites have refill requests:",!
FOR PSOVX=0:0
SET PSOVX=$ORDER(PSOVEXI(PSOVX))
if 'PSOVX
QUIT
IF $GET(PSOVEXI(PSOVX))
WRITE !?5,$PIECE($GET(^PS(59,+$GET(PSOVX),0)),"^")
+15 IF $GET(PSOVEXFL)
WRITE !
SET DIR(0)="E"
SET DIR("A")="Press Return to Continue, '^' to exit"
SET DIR("T")=DTIME
DO ^DIR
WRITE !
IF Y'=1
SET QUIT=1
QUIT
+16 if '$DATA(PSOPAR)
DO ^PSOLSET
IF $GET(PSOQUIT)!'$DATA(PSOPAR)
SET QUIT=1
QUIT
+17 WRITE !!!?20,"Division: "_$PIECE(^PS(59,PSOSITE,0),"^"),!!
+18 SET PSOBBC1("FROM")="REFILL"
SET PSOBBC("QFLG")=0
SET PSOBBC("DFLG")=0
+19 IF '$DATA(^PS(52.444,"C",PSOSITE))
SET PSOANS="N"
WRITE !!,"There are no telephone refills to process for the selected division."
SET QUIT=1
QUIT
+20 DO ASK^PSOBBC
if PSOBBC("QFLG")=1
WRITE !,"No telephone refills were processed."
IF PSOBBC("QFLG")=1
SET QUIT=1
QUIT
PSOX WRITE !
SET DIR("A")="Process telephone refill requests at this time"
SET DIR("B")="YES"
SET DIR(0)="Y"
SET DIR("T")=DTIME
DO ^DIR
KILL DIR
SET PSOANS="N"
IF $GET(DIRUT)!(Y=0)
SET QUIT=1
WRITE !?7,$CHAR(7),"No telephone refills were processed."
QUIT
+1 SET PSORXIEN=""
IF Y=1
SET PSOANS="Y"
+2 ;parameter from 59 for all divisions default prompt answer
SET PSOPTRAD=$$GET1^DIQ(59,PSOSITE,4.2)
+3 ; initialize the answer to the processing all divisions prompt
SET PSOANS2="S"
+4 IF PSOANS["Y"
IF $$GET1^DIQ(59.7,1,"INTERDIVISIONAL PROCESSING","I")
Begin DoDot:1
+5 SET DIR("A")="Process telephone refills for all divisions"
SET DIR("B")=PSOPTRAD
SET DIR(0)="Y"
SET DIR("T")=DTIME
+6 WRITE !
+7 SET DIR("?",1)="Enter 'YES' to process all division refill requests."
+8 SET DIR("?",2)="Enter 'NO' to only process refill request for the division you selected when you logged on."
+9 SET DIR("?")=" "
+10 DO ^DIR
KILL DIR
if Y=1
SET PSOANS2="M"
End DoDot:1
IF $GET(DIRUT)
SET PSOANS="N"
SET QUIT=1
WRITE !?7,$CHAR(7),"No telephone refills were processed."
QUIT
+11 IF PSOANS2["S"
SET PSONO=$DATA(^PS(52.444,"C",PSOSITE))
IF '$GET(PSONO)
WRITE !,"There are no requests for your selected division."
QUIT
+12 ; use to indicate first time through for mail msg build
SET PSOCNT1=10
+13 SET $PIECE(LN,"-",80)=""
SET PSOCNT=0
PSO6 ;MARK PROCESSED NODES
IF PSOANS["Y"
IF $GET(PSORXIEN)
SET PSORXEN=0
SET PSORXEN=$ORDER(^PS(52.444,"B",PSORXIEN,PSORXEN))
DO PSO5
+1 IF PSOANS="N"
SET PSORX=PSORXIEN
DO ULK
GOTO END
+2 DO PSO3
IF $GET(PSOANS)="N"
SET PSORX=PSORXIEN
DO ULK
GOTO END
+3 IF 'PSOSITE
WRITE !?7,$CHAR(7),$CHAR(7),$CHAR(7),"Not from this institution.",!
SET PSORX=PSORXIEN
DO ULK
GOTO PSO6
+4 IF $LENGTH(PSORENEW)
SET PSORENEW=""
GOTO PSO6
+5 SET (PSOBBC("IRXN"),PSOBBC("OIRXN"))=PSORXIEN
+6 IF $DATA(^PSRX(PSOBBC("IRXN"),0))']""
WRITE !,$CHAR(7),"Rx data is not on file!",!
SET PSORX=PSORXIEN
DO ULK
GOTO PSO6
+7 IF $PIECE($GET(^PSRX(PSOBBC("IRXN"),"STA")),"^")=13
WRITE !,$CHAR(7),"Rx has already been deleted."
SET PSORX=PSORXIEN
DO ULK
GOTO PSO6
+8 IF $GET(PSOBBC("DONE"))[PSOBBC("IRXN")_","
WRITE !,$CHAR(7),"Rx has already been entered."
SET PSORX=PSORXIEN
DO ULK
GOTO PSO6
+9 KILL X,Y
if PSOBBC("QFLG")
DO PROCESSX^PSOBBC
+10 SET PSOSELSE=0
IF $GET(PSODFN)'=$PIECE(^PSRX(PSOBBC("IRXN"),0),"^",2)
SET PSOSELSE=1
WRITE !,LN
DO PT^PSOBBC
IF $GET(PSOBBC("DFLG"))
KILL PSOSELSE
SET PSORX=PSORXIEN
DO ULK
GOTO PSO6
+11 IF '$GET(PSOSELSE)
WRITE !,LN
DO PTC^PSOBBC
IF $GET(PSOBBC("DFLG"))
KILL PSOSELSE
SET PSORX=PSORXIEN
DO ULK
GOTO PSO6
+12 KILL PSOSELSE
DO PROFILE^PSORX1
+13 ;p677 handle multi division
+14 ;S PSOBBC("DONE")=PSOBBC("IRXN")_"," D REFILL^PSOBBC
+15 SET PSOKPK=1
+16 IF '$PIECE($GET(PSOSYS),"^",2)
DO REFILL^PSOBBC
IF 1
+17 IF '$TEST
Begin DoDot:1
+18 IF PSOSITE'=$PIECE(^PSRX(PSORXIEN,2),U,9)
SET PSOBBC("PSOVEXRX")=PSOSITE
NEW PSOSITE
SET PSOSITE=$PIECE(^PSRX(PSORXIEN,2),U,9)
+19 DO REFILL^PSOBBC
+20 KILL PSOBBC("PSOVEXRX")
End DoDot:1
+21 SET PSOBBC("DONE")=PSOBBC("IRXN")_","
+22 IF $$TITRX^PSOUTL(PSOBBC("IRXN"))="t"
IF '$GET(UNPARK)
SET PSOBBC("DFLG")=1
+23 SET PSORX=PSORXIEN
DO ULK
GOTO PSO6
+24 ;
PSO3 ; avoid skipping renewal requests.
+1 NEW PSOPP
+2 KILL PSOBBC("IRXN"),PSOXFLAG,PSOPP
if '$GET(PSORXIEN)
SET PSORXIEN=0
FOR
SET PSORXIEN=$ORDER(^PS(52.444,"B",PSORXIEN))
Begin DoDot:1
+3 IF PSORXIEN=""
SET PSOANS="N"
QUIT
+4 IF PSOANS2["S"
IF $DATA(^PSRX(PSORXIEN,0))
IF PSOSITE'=$PIECE(^PSRX(PSORXIEN,2),"^",9)
QUIT
+5 SET PSORXEN=0
FOR
SET PSORXEN=$ORDER(^PS(52.444,"B",PSORXIEN,PSORXEN))
if 'PSORXEN
QUIT
Begin DoDot:2
+6 IF $PIECE(^PS(52.444,PSORXEN,0),U,4)
SET ^TMP("PSOFILLED",$JOB,PSORXIEN)=""
+7 ;Quit if date processed exists
if ($PIECE(^PS(52.444,PSORXEN,0),U,4))
QUIT
+8 SET PSOCNT=PSOCNT+1
+9 SET PSO648=0
SET PSOREN=$PIECE(^PS(52.444,PSORXEN,0),U,4,9)
IF PSOREN]""
DO BFDRNCHK
+10 ;CANNOT PROCESS RENEWAL ENTRIES CONTAINING TILDE CHARACTER (~) IN THE FREE TEXT DOSAGE FIELD
+11 IF ($PIECE($GET(PSOREN),U,3)]"")
SET PSOTILDE=$$TILDECHK^PSOVEXR1(PSORXIEN,PSORXEN)
IF +PSOTILDE
DO PSO7(PSORXIEN,PSOTILDE)
KILL PSOTILDE
if '$GET(DUOUT)
QUIT
IF $GET(DUOUT)
SET PSOANS="N"
QUIT
+12 ;SKIPS ERRONEOUS ENTRIES
IF '$DATA(^PSRX(PSORXIEN,0))
IF PSO648=1
DO PSO5
QUIT
+13 ;SKIPS ENTRIES ALREADY PROCESSED AND FORMATS VARIABLE X (BFD/648 LINE)
IF PSOANS["Y"
if PSO648=1
QUIT
+14 DO RENEWCHK
IF PSORENEW]""
SET PSOXFLAG=1
QUIT
+15 IF PSORXIEN
SET PSORX=PSORXIEN
DO PSOL^PSSLOCK(PSORX)
IF '$GET(PSOMSG)
KILL PSORX,PSOMSG
QUIT
+16 KILL PSOMSG
SET PSOXFLAG=1
End DoDot:2
End DoDot:1
if PSOANS="N"!($GET(PSOXFLAG))
QUIT
+17 IF 'PSOCNT
WRITE !!,"There are NO telephone refills to process."
+18 QUIT
+19 ; -----------------------------------------------------------------------------------
PSO5 ; Mark the node as processed.
+1 KILL FDA,IENS
+2 SET PSORXIEN=$PIECE(^PS(52.444,PSORXEN,0),U)
+3 ;marks node as processed
IF PSOREFLG=0
SET IENS=PSORXEN_","
SET FDA(52.444,IENS,3)=DT
DO FILE^DIE(,"FDA","PSOERR")
Begin DoDot:1
+4 IF $GET(PSOKPK)>1
SET PSOKPK=1
QUIT
+5 ;FLAGS UNSUCCESSFUL ATTEMPTS TO REFILL.
IF $GET(PSOBBC("DFLG"))
DO PSO12
End DoDot:1
+6 IF PSONRFLG=0
IF (PSOREFLG=0)
SET PSORFY=PSORFY+1
+7 SET PSONRFLG=0
+8 IF '$GET(PSOBBC("DFLG"))
IF PSORSULT=1
WRITE !,LN,!,"Prescription: RX # "_$PIECE(^PSRX(PSORXIEN,0),U)_" Processed",!
+9 QUIT
+10 ;
PSO7(PSORXIEN,PSOTILDE) ; Add skipped prescriptions due to tilde error to the report
+1 ; input = PSORXIEN - ien of RX in PRESCRIPTION file (#52)
+2 ; input = PSOTILDE - string representing the results of Tilde check
+3 ; first piece = 1 or 0; where 1 means it's an RX with a Tilde in the dosage form
+4 ; second piece = 1 or 0; where 1 means it's a controlled substance RX
+5 ;
+6 NEW LAST,PSORET,TXT,XX
+7 ; Tilde RX is a controlled substance
+8 IF $PIECE(PSOTILDE,"^",2)
Begin DoDot:1
+9 SET LAST=0
IF $DATA(^TMP($JOB,"ORAREN E"))
SET LAST=$ORDER(^TMP($JOB,"ORAREN E",9999),-1)
+10 IF LAST>0
SET LAST=LAST+1
SET ^TMP($JOB,"ORAREN E",LAST,0)=" "
+11 SET (TXT(1),^TMP($JOB,"ORAREN E",LAST+1,0))="RX # "_$PIECE(^PSRX(PSORXIEN,0),U)
+12 SET (TXT(2),^TMP($JOB,"ORAREN E",LAST+2,0))="This controlled substance prescription cannot generate a notification to"
+13 SET (TXT(3),^TMP($JOB,"ORAREN E",LAST+3,0))="the provider because there is a tilde (~) character in the dosage field. "
+14 SET (TXT(4),^TMP($JOB,"ORAREN E",LAST+4,0))="Using CPRS, flag the requested order and ask the provider to correct"
+15 SET (TXT(5),^TMP($JOB,"ORAREN E",LAST+5,0))="the order by removing the tilde (~) from the free text dosage using"
+16 SET (TXT(6),^TMP($JOB,"ORAREN E",LAST+6,0))="Change or Copy to New Order. When the corrected order is digitally"
+17 SET (TXT(7),^TMP($JOB,"ORAREN E",LAST+7,0))="signed, a Pending order is created for the pharmacy to finish."
+18 SET (TXT(8),^TMP($JOB,"ORAREN E",LAST+8,0))=""
+19 WRITE !,LN
+20 SET XX=0
FOR
SET XX=$ORDER(TXT(XX))
if XX=""
QUIT
WRITE !,TXT(XX)
+21 WRITE !
End DoDot:1
GOTO PSO7X
+22 ; Tilde RX not a controlled substance
+23 SET LAST=0
IF $DATA(^TMP($JOB,"ORAREN E"))
SET LAST=$ORDER(^TMP($JOB,"ORAREN E",9999),-1)
+24 IF LAST>0
SET LAST=LAST+1
SET ^TMP($JOB,"ORAREN E",LAST,0)=" "
+25 SET (TXT(1),^TMP($JOB,"ORAREN E",LAST+1,0))="RX # "_$PIECE(^PSRX(PSORXIEN,0),U)
+26 SET (TXT(2),^TMP($JOB,"ORAREN E",LAST+2,0))="This prescription cannot be renewed because there is a tilde (~)"
+27 SET (TXT(3),^TMP($JOB,"ORAREN E",LAST+3,0))="character in the dosage field. Using CPRS, flag the requested"
+28 SET (TXT(4),^TMP($JOB,"ORAREN E",LAST+4,0))="order and ask the provider to remove the tilde (~) from the free"
+29 SET (TXT(5),^TMP($JOB,"ORAREN E",LAST+5,0))="text dosage when Renewing. After the corrected order is digitally"
+30 SET (TXT(6),^TMP($JOB,"ORAREN E",LAST+6,0))="signed, a Pending order is created for the pharmacy to finish."
+31 SET (TXT(7),^TMP($JOB,"ORAREN E",LAST+7,0))=" "
+32 WRITE !,LN
+33 SET XX=0
FOR
SET XX=$ORDER(TXT(XX))
if XX=""
QUIT
WRITE !,TXT(XX)
PSO7X ;
+1 SET PSOTOTF=$GET(PSOTOTF)+1
+2 WRITE !
SET DIR("A")="Enter <RETURN> to continue."
SET DIR(0)="FO"
SET DIR("T")=DTIME
+3 SET DIR("?")=" "
SET DIR("?",1)="Answering ""^"" will abort processing and the remaining refills will not"
+4 SET DIR("?",2)="be processed."
+5 DO ^DIR
KILL DIR
+6 QUIT
+7 ;
PSO12 ; refill not processed.
+1 KILL FDA,IENS
+2 SET PSONRF=PSONRF+1
SET PSONRFLG=1
+3 ;NOTE THE IENS MUST HAVE A FINAL COMMA ADDED TO THE ENTRY NUMBER.
SET IENS=PSORXEN_","
+4 SET FDA(52.444,IENS,4)="NOT FILLED"
DO FILE^DIE(,"FDA","PSOERR")
+5 WRITE !,"Prescription REFILL, RX # "_$PIECE(^PSRX(PSORXIEN,0),U)_", was not processed. ",!," PLEASE TAKE APPROPRIATE ACTION."
+6 SET DIR("?",1)="Answering YES will continue to process the remaining Telephone Refill"
+7 SET DIR("?",2)="Requests. "
+8 SET DIR("?",3)=""
+9 SET DIR("?",4)="Answering NO will abort processing and the remaining refills will not be"
+10 SET DIR("?")="processed. The option will need to be run again to continue processing."
+11 WRITE !
SET DIR("A")="Do you wish to continue processing the remaining refill requests"
SET DIR("B")="YES"
SET DIR(0)="Y"
SET DIR("T")=DTIME
DO ^DIR
+12 WRITE !
KILL DIR
IF Y'=1
SET PSOANS="N"
+13 QUIT
END DO PROCESSX^PSOBBC
+1 KILL XMY
NEW XMDUZ,XMSUB,XMTEXT,XMT
+2 SET XMDUZ="AUTO,RENEWAL"
SET XMY(DUZ)=""
SET XMY("G.AUTORENEWAL")=""
SET XMSUB=$SELECT($GET(PSOANS2)["S":$$GET1^DIQ(59,PSOSITE,.01)_" ",1:"")_"REFILL TOTALS"
SET XMTEXT="XMT("
+3 SET XMT(1,0)="Refills Processed: "_PSORFY
SET XMT(2,0)="Refills 'Not Processed': "_PSONRF
+4 SET XMT(3,0)=" "
SET XMT(4,0)="Renewals sent to provider: "_PSOTTREN
+5 SET XMT(5,0)="Renewals not sent to provider: "_PSOTOTF
+6 DO ^XMD
+7 IF $DATA(^TMP($JOB))
KILL XMY
NEW XMDUZ,XMSUB,XMTEXT
Begin DoDot:1
+8 SET XMY(DUZ)=""
+9 IF $DATA(^TMP($JOB,"ORAREN E"))
SET XMDUZ="AUTO,RENEWAL"
SET XMY("G.AUTORENEWAL")=""
SET XMSUB=$SELECT($GET(PSOANS2)["S":$$GET1^DIQ(59,PSOSITE,.01)_" ",1:"")_"RENEWAL REQUESTS NOT SENT TO PROVIDERS"
SET XMTEXT="^TMP("_$JOB_",""ORAREN E"","
DO ^XMD
+10 IF $DATA(^TMP($JOB,"ORAREN OC"))
SET XMDUZ="AUTO,RENEWAL"
SET XMY("G.AUTORENEWAL")=""
SET XMSUB=$SELECT($GET(PSOANS2)["S":$$GET1^DIQ(59,PSOSITE,.01)_" ",1:"")_"RENEWAL REQUESTS WITH ORDER CHECKS"
SET XMTEXT="^TMP("_$JOB_",""ORAREN OC"","
DO ^XMD
End DoDot:1
+11 IF $PIECE($GET(^PS(59,+$GET(PSOSITE),"I")),"^")
IF DT>$PIECE($GET(^("I")),"^")
DO FINAL^PSOLSET
WRITE !!,"Your Outpatient Site parameters have been deleted because you selected an",!,"inactive Outpatient Site!",!
+12 KILL DIR,DIRUT,DUOUT,PSOBBC,PSOBBC1
+13 QUIT
ULK ; unlock a record.
+1 NEW SAVE
+2 IF '$GET(PSORX)
QUIT
+3 DO PSOUL^PSSLOCK(PSORX)
+4 MERGE SAVE=PSORX
+5 KILL PSORX
+6 SET PSORX("FILL DATE")=$GET(SAVE("FILL DATE"))
SET PSORX("MAIL/WINDOW")=$GET(SAVE("MAIL/WINDOW"))
SET PSORX("METHOD OF PICK-UP")=$GET(SAVE("METHOD OF PICK-UP"))
+7 QUIT
+8 ; -----------------------------------------------------------------------------------
RENEWCHK ; Checks ^PS(52.444 node for renewal information
+1 KILL FDA,IENS
+2 SET (PSOREFLG,PSORSULT)=0
+3 SET PSORENEW=$PIECE(PSOREN,"^",3)
SET PSOPROVP=$PIECE(PSOREN,"^",6)
+4 IF PSORENEW="U"!(PSORENEW="I")!(PSORENEW="N")
Begin DoDot:1
+5 SET PSORXIEN=+$PIECE(^PS(52.444,PSORXEN,0),U)
SET PSODFN=+$PIECE(^PS(52.444,PSORXEN,0),U,3)
+6 ;ICR 5498
DO RENEW^ORAREN(.PSORSULT,PSODFN,PSORXIEN,PSOPROVP,PSORENEW)
+7 SET PSOREFLG=1
+8 ;marks node as processed
SET IENS=PSORXEN_","
SET FDA(52.444,IENS,3)=DT
DO FILE^DIE(,"FDA","PSOERR")
+9 ;marks the result from RENEW^ORAREN processing
SET IENS=PSORXEN_","
SET FDA(52.444,IENS,6)=PSORSULT
DO FILE^DIE(,"FDA","PSOERR")
+10 IF PSORSULT=0
SET PSOCNT1=PSOCNT1+1
+11 IF PSORSULT'=1
SET PSOTOTF=PSOTOTF+1
WRITE !,LN,!,$CHAR(7),"Prescription Renewal Request, RX # "_$PIECE(^PSRX(PSORXIEN,0),U)_", was not sent to the provider. ",!," PLEASE TAKE APPROPRIATE ACTION."
+12 IF PSORSULT=1
SET PSOTTREN=PSOTTREN+1
+13 QUIT
End DoDot:1
+14 QUIT
BFDRNCHK ; There is data in global - is it date or renewal request
+1 ;"if there is something in the Date piece S PSO648=1 to stop processing"
+2 IF $PIECE(PSOREN,"^",1)]""
SET PSO648=1
+3 ;if there are more than just piece 1 but the
+4 IF $PIECE(PSOREN,"^",1)']""
SET PSO648=0
+5 ;"if PSO648 is 0 then no date but renewal"
+6 QUIT
+7 ;
SUMM ; display summary of refills processed
+1 SET DIR("A")="Display the full summary of individual orders processed"
+2 SET DIR("B")="NO"
SET DIR(0)="Y"
+3 SET DIR("?",1)="Enter 'YES' to display the summary of orders processed in this session."
+4 SET DIR("?",2)="Enter 'NO' to not display the summary."
+5 SET DIR("?")=" "
+6 DO ^DIR
KILL DIR
+7 IF $GET(DIRUT)
SET QUIT=1
QUIT
+8 SET PRINT=$SELECT(+Y=1:1,1:0)
+9 IF PRINT
WRITE !!!,"TELEPHONE REFILL/RENEW SUMMARY",!!
+10 QUIT
