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

PSOVEXRX.m

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