PSOERXU3 ;ALB/BWF - eRx utilities ; 5/26/2017 9:57am
;;7.0;OUTPATIENT PHARMACY;**508,591,606,581,617,646,700**;DEC 1997;Build 261
;
Q
; PSO*508 - Added MEDDIS, RRREQ, and RRRES linetags.
; ERXIEN - IEN FROM 52.49
; DTYPE - R for REQUESTED, or D for dispensed drugs
MEDDIS(ERXIEN,DTYPE,LINE) ;
N DRUG,DIEN,QTY,DAYS,WDATE,EFDATE,REFILL,EXDATE,LFDATE,DIRECT,CLQ,USC,PUC,F,IENS,I,LTXT
N RXIEN,RXNUM,INS,DDAT,PARIEN,OREFILL,DLOOP,DIRARY,MTYPE,QUOM
S F=52.4949
S MTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
S LINE=LINE+1 D SET^VALM10(LINE,"")
S LINE=LINE+1 D SET^VALM10(LINE,"****************************MEDICATION DISPENSED****************************")
S PARIEN=$$RESOLV^PSOERXU2(ERXIEN)
I PARIEN S RXIEN=$$GET1^DIQ(52.49,PARIEN,.13,"I")
I PARIEN S QUOM=$$GET1^DIQ(52.49,PARIEN,5.4,"E")
I $E($G(QUOM))="C" S QUOM=$$CODERES^PSOERXU7(QUOM,"NCI")
I $G(RXIEN) S OREFILL=$$GET1^DIQ(52,RXIEN,9,"E")
S I=0 F S I=$O(^PS(52.49,ERXIEN,49,I)) Q:'I D
.S IENS=I_","_ERXIEN_","
.;Q:$$GET1^DIQ(F,IENS,.02,"I")'=DTYPE
.D GETS^DIQ(F,IENS,"**","IE","DDAT")
.S DRUG=$G(DDAT(F,IENS,.01,"E"))
.S DIEN=$G(DDAT(F,IENS,.03,"I"))
.S QTY=$G(DDAT(F,IENS,.04,"E"))
.S DAYS=$G(DDAT(F,IENS,.05,"E"))
.S REFILL=$G(DDAT(F,IENS,.06,"E"))
.S DIRECT=$G(DDAT(F,IENS,1,"E"))
.S WDATE=$G(DDAT(F,IENS,2.1,"E"))
.S LFDATE=$G(DDAT(F,IENS,2.2,"E"))
.S EXDATE=$G(DDAT(F,IENS,2.3,"E"))
.S EFDATE=$G(DDAT(F,IENS,2.4,"E"))
.S CLQ=$G(DDAT(F,IENS,2.5,"E"))
.S USC=$G(DDAT(F,IENS,2.6,"E"))
.S PUC=$G(DDAT(F,IENS,2.7,"E"))
.; if there is an RX ien, reset the refills to that value - may need to adjust other fields as well
.I $G(RXIEN) S REFILL=$$GET1^DIQ(52,RXIEN,9,"E")
.S LINE=LINE+1 D SET^VALM10(LINE,"Vista Drug: "_DRUG_" "_$P($$VADRSCH^PSOERXUT(+$G(DIEN)),"^",3))
.S LINE=LINE+1
.D ADDITEM^PSOERX1A(.LTXT,"Vista Qty: ",$G(QTY),1,25)
.D ADDITEM^PSOERX1A(.LTXT,"Vista Refills: ",$G(REFILL),27,18)
.D ADDITEM^PSOERX1A(.LTXT,"Vista Days Supply: ",$G(DAYS),54,22)
.D SET^VALM10(LINE,LTXT) S LTXT=""
.S LINE=LINE+1 D SET^VALM10(LINE,"Quantity Unit of Measure: "_$G(QUOM))
.S DIRECT="Vista Sig: "_DIRECT
.D TXT2ARY^PSOERXD1(.DIRARY,DIRECT," ",75)
.S DLOOP=0 F S DLOOP=$O(DIRARY(DLOOP)) Q:'DLOOP D
..S LINE=LINE+1
..D SET^VALM10(LINE,$G(DIRARY(DLOOP)))
I $G(RXIEN) D
.S RXNUM=$$GET1^DIQ(52,RXIEN,.01,"E")
.S INS=0 F S INS=$O(^PSRX(RXIEN,"INS1",INS)) Q:'INS D
..S LINE=LINE+1 D SET^VALM10(LINE,"Pat Inst: "_$$GET1^DIQ(52.0115,INS_","_RXIEN_",",.01,"E"))
I '$L($G(RXNUM)) S RXNUM="Unable to resolve."
S LINE=LINE+1 D SET^VALM10(LINE,"VA Rx#: "_$G(RXNUM))
Q
; refill request information
RRREQ(ERXIEN,LINE) ;
N REQBY,REQDTTM,REFREQ,COMM,COMMARY,I,COMMBY,COMMDTTM,CTXT,REQIEN,S2017
S REQIEN=ERXIEN
I $$GET1^DIQ(52.49,ERXIEN,.08,"I")="RE" S REQIEN=$$RESOLV^PSOERXU2(ERXIEN)
S REQBY=$$GET1^DIQ(52.49,REQIEN,51.1,"E")
S REFREQ=$$GET1^DIQ(52.49,REQIEN,51.2,"E")
S REQDTTM=$$GET1^DIQ(52.49,REQIEN,.03,"E")
S COMM=$$GET1^DIQ(52.49,REQIEN,50,"E")
S S2017=$$GET1^DIQ(52.49,ERXIEN,312.1)
S LINE=LINE+1 D SET^VALM10(LINE,"")
S LINE=LINE+1 D SET^VALM10(LINE,"************************RXRENEWAL REQUEST INFORMATION**************************")
S LINE=LINE+1 D SET^VALM10(LINE,"Requested By: "_REQBY)
S LINE=LINE+1 D SET^VALM10(LINE,"Request Date/Time: "_REQDTTM)
S LINE=LINE+1 D SET^VALM10(LINE,"# of Refills Requested: "_REFREQ)
S LINE=LINE+1 D SET^VALM10(LINE,"")
S COMM="RxRenewal Request Comments: "_COMM
D TXT2ARY^PSOERXD1(.COMMARY,COMM," ",80)
S I=0 F S I=$O(COMMARY(I)) Q:'I D
.S CTXT=$G(COMMARY(I))
.S LINE=LINE+1 D SET^VALM10(LINE,CTXT)
S COMMBY=$$GET1^DIQ(52.49,REQIEN,50.1,"E")
S COMMDTTM=$$GET1^DIQ(52.49,REQIEN,50.2,"E")
S LINE=LINE+1 D SET^VALM10(LINE,"Comments By: "_COMMBY)
S LINE=LINE+1 D SET^VALM10(LINE,"Comments Date/Time: "_COMMDTTM)
Q
;
MSGHIS(ERXIEN,LINE) ;
N FLAG
S FLAG=+$G(FLAG)
N ERXREF,RELERX,ERXRES,I,ERXHID,FOUND,REQID,RESID,MTYPE
S MTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
I ",RR,CA,CR,"[(","_MTYPE_",") S REQIEN=ERXIEN,RESIEN=$$GETRESP^PSOERXU2(ERXIEN)
I ",RE,CN,CX,"[(","_MTYPE_",") S RESIEN=ERXIEN,REQIEN=$$RESOLV^PSOERXU2(ERXIEN)
I MTYPE="IE" S RESIEN=ERXIEN,REQIEN=$$RESOLV^PSOERXU2(ERXIEN)
S RESID=$$GET1^DIQ(52.49,RESIEN,.01,"E")
S REQID=$$GET1^DIQ(52.49,REQIEN,.01,"E")
S RELERX=$$GET1^DIQ(52.49,REQIEN,.14)
S FOUND=0
S I=ERXIEN F S I=$O(^PS(52.49,ERXIEN,201,"B",I)) Q:'I!(FOUND) D
.I $$GET1^DIQ(52.49,I,.08,"E")="RE",$$GET1^DIQ(52.49,I,.14,"E")=$$GET1^DIQ(52.49,ERXIEN,.01,"E") S ERXRES=$$GET1^DIQ(52.49,I,.14,"E"),FOUND=1
S LINE=LINE+1 D SET^VALM10(LINE,"")
S LINE=LINE+1 D SET^VALM10(LINE,"*****************************MESSAGE HISTORY********************************")
S LINE=LINE+1 D SET^VALM10(LINE,"Request Reference #: "_$G(REQID))
S LINE=LINE+1 D SET^VALM10(LINE,"New eRx Reference #: "_RELERX)
S LINE=LINE+1 D SET^VALM10(LINE,"Response eRx Reference #: "_$G(RESID))
Q
; refill response information
RRRES(ERXIEN,LINE,PMODE) ;p646 added PMODE parameter.
; If PMODE is greater than 0 then the video control calls will be utilized.
N RESVAL,RESNOTE,I,RESCODE,RESDTTM,RESDESC,ERXDAT,IENS,RESIEN,RECODE,RESTEXT,MTYPE,REQIEN,CODEIEN
N STR1ARY,STR2ARY,J,STR1,STR2,DELTA,FN,COMM,COMMARY,COMMBY,COMMDTTM,ERESCODE,S2017,REQS2017,RESS2017
S MTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
I MTYPE="RE"!(MTYPE="CN") S RESIEN=ERXIEN,REQIEN=$$RESOLV^PSOERXU2(ERXIEN)
I MTYPE="RR"!(MTYPE="CA") S REQIEN=ERXIEN,RESIEN=$$GETRESP^PSOERXU2(ERXIEN) Q:'RESIEN
S REQS2017=$$GET1^DIQ(52.49,REQIEN,312.1)
S RESS2017=$$GET1^DIQ(52.49,RESIEN,312.1)
S IENS=RESIEN_","
D GETS^DIQ(52.49,RESIEN,".03;.13;52.1;52.2;52.3","IE","ERXDAT")
S RESVAL=$G(ERXDAT(52.49,IENS,52.1,"E"))
S RESCODE=$G(ERXDAT(52.49,IENS,52.1,"I"))
S RESNOTE=$G(ERXDAT(52.49,IENS,52.2,"E"))
S RESDTTM=$G(ERXDAT(52.49,IENS,.03,"E"))
S LINE=LINE+1 D SET^VALM10(LINE,"")
S LINE=LINE+1 D SET^VALM10(LINE,"************************RXRENEWAL RESPONSE INFORMATION**************************")
S LINE=LINE+1 D SET^VALM10(LINE,RESVAL) D:$G(PMODE) CNTRL^VALM10(LINE,1,$L(RESVAL),IORVON,IORVOFF)
S LINE=LINE+1 D SET^VALM10(LINE,"Response Date/Time: "_RESDTTM)
S LINE=LINE+1 D SET^VALM10(LINE,"Note: "_RESNOTE)
S LINE=LINE+1 D SET^VALM10(LINE,"")
S COMM=$$GET1^DIQ(52.49,RESIEN,50,"E")
S COMM="RxRenewal Response Comments: "_COMM
D TXT2ARY^PSOERXD1(.COMMARY,COMM," ",80)
S I=0 F S I=$O(COMMARY(I)) Q:'I D
.S CTXT=$G(COMMARY(I))
.S LINE=LINE+1 D SET^VALM10(LINE,CTXT)
S COMMBY=$$GET1^DIQ(52.49,RESIEN,50.1,"E")
S COMMDTTM=$$GET1^DIQ(52.49,RESIEN,50.2,"E")
S LINE=LINE+1 D SET^VALM10(LINE,"Comments By: "_COMMBY)
S LINE=LINE+1 D SET^VALM10(LINE,"Comments Date/Time: "_COMMDTTM)
S LINE=LINE+1 D SET^VALM10(LINE,"")
S I=0 F S I=$O(^PS(52.49,RESIEN,55,I)) Q:'I D
.S ERESCODE=$$GET1^DIQ(52.4955,I_","_IENS,.01,"E")
.S CODEIEN=$$GET1^DIQ(52.4955,I_","_IENS,.01,"I")
.S RESDESC=$$GET1^DIQ(52.45,CODEIEN,.02,"E")
.S RESTEXT=RESVAL_" reason code: "_ERESCODE
.S LINE=LINE+1 D SET^VALM10(LINE,RESTEXT) D:$G(PMODE) CNTRL^VALM10(LINE,1,$L(RESTEXT),IORVON,IORVOFF)
.S LINE=LINE+1 D SET^VALM10(LINE,"Code Description: "_RESDESC)
.S LINE=LINE+1 D SET^VALM10(LINE,"")
I '$G(REQS2017),'$G(RESS2017) D
.I RESCODE="AWC"!(RESCODE="A") D
..D RRDELTA^PSOERXU2(.DELTA,REQIEN,RESIEN) Q:'$D(DELTA)
..S LINE=LINE+1 D SET^VALM10(LINE,"********************************CHANGED ITEMS***********************************")
..S I=0 F S I=$O(DELTA(I)) Q:'I D
...S FN="" F S FN=$O(DELTA(I,FN)) Q:FN="" D
....K STR1ARY,STR2ARY
....S LINE=LINE+1 D SET^VALM10(LINE,"Field: "_FN) D:$G(PMODE) CNTRL^VALM10(LINE,1,$L(FN)+7,IORVON,IORVOFF)
....S STR1="RxRenewal Request Value : "_$P(DELTA(I,FN),U)
....D TXT2ARY^PSOERXD1(.STR1ARY,STR1," ",78)
....S STR2="RxRenewal Response Value : "_$P(DELTA(I,FN),U,2)
....D TXT2ARY^PSOERXD1(.STR2ARY,STR2," ",78)
....S J=0 F S J=$O(STR1ARY(J)) Q:'J D
.....S LINE=LINE+1 D SET^VALM10(LINE," "_$G(STR1ARY(J)))
....S J=0 F S J=$O(STR2ARY(J)) Q:'J D
.....S LINE=LINE+1 D SET^VALM10(LINE," "_$G(STR2ARY(J)))
....S LINE=LINE+1 D SET^VALM10(LINE,"")
Q
ERRDISP(ERXIEN,LINE) ;
D ERRDISP^PSOERXU7(ERXIEN,.LINE)
Q
; displays processing errors
PROCERR(ERXIEN,LINE) ;
N ERRIEN,ERRIENS,ERRTXT,ERRTARY
; quit if there are no processing errors
Q:'$D(^PS(52.49,ERXIEN,100,"C","PX"))
S LINE=LINE+1 D SET^VALM10(LINE,"")
S LINE=LINE+1 D SET^VALM10(LINE,"****************************PROCESSING ERRORS*******************************")
S ERRIEN=0 F S ERRIEN=$O(^PS(52.49,ERXIEN,100,ERRIEN)) Q:'ERRIEN D
.S ERRIENS=ERRIEN_","_ERXIEN_","
.S ERRTXT=$$GET1^DIQ(52.49101,ERRIENS,1,"E")
.S ERRTXT="Error Details: "_ERRTXT
.D TXT2ARY^PSOERXD1(.ERRTARY,ERRTXT," ",78)
.S I=0 F S I=$O(ERRTARY(I)) Q:'I D
..S LINE=LINE+1 D SET^VALM10(LINE,$G(ERRTARY(I)))
.K ERRTXT,ERRTARY
Q
; automatically DC a prescription if a denied, new prescription to follow is recieved
AUTODC(ERXIEN) ;
N PSODFN,RXIEN,PSOLST,ORN,PSOOPT,PSOSITE,PSODIV,PSOSYS,PSODIV,PSOSYS,NERXIEN
N RTYPE,REQIEN,ERRSEQ,VALMSG,ERXIENS,RXSTAT,PSTAT,MTYPE
Q:'ERXIEN
S ERXIENS=ERXIEN_","
; get the RXIEN
S REQIEN=$$RESOLV^PSOERXU2(ERXIEN)
I REQIEN S NERXIEN=$$RESOLV^PSOERXU2(REQIEN)
S MTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
S RTYPE=$$GET1^DIQ(52.49,ERXIEN,52.1,"I")
; if for some reason the newrx could not be identified, there is no way we can auto-dc, so quit
Q:'$P($G(NERXIEN),U)
S RXIEN=$$GET1^DIQ(52.49,NERXIEN,.13,"I") Q:RXIEN=""
; if already DC'd, do not try to DC again
S RXSTAT=$$GET1^DIQ(52,RXIEN,100,"I")
I (RXSTAT=12)!(RXSTAT=14)!(RXSTAT=15) D Q
.S ERRSEQ=$$ERRSEQ^PSOERXU1(ERXIEN) Q:'ERRSEQ
.S VALMSG="eRx auto-discontinue failed. Prescription is already discontinued."
.D FILERR^PSOERXU1(ERXIENS,ERRSEQ,"PX","V",$G(VALMSG))
.I MTYPE="CX" D Q
..D UPDSTAT^PSOERXU1(ERXIEN,"CXE",$G(VALMSG))
..I REQIEN,$$GET1^DIQ(52.49,REQIEN,1,"E")'="CRR" D UPDSTAT^PSOERXU1(REQIEN,"CRR",$G(VALMSG))
.I REQIEN,$$GET1^DIQ(52.49,REQIEN,1,"E")'="RRR" D UPDSTAT^PSOERXU1(REQIEN,"RRR",$G(VALMSG))
.I RTYPE="R" D UPDSTAT^PSOERXU1(ERXIEN,"RXE",$G(VALMSG)) Q
.D UPDSTAT^PSOERXU1(ERXIEN,"RXF",$G(VALMSG))
S PSOSITE=$$GET1^DIQ(52,RXIEN,20,"I")
S PSOSYS=$G(^PS(59.7,1,40.1)) Q:PSOSYS=""
S PSODFN=$$GET1^DIQ(52,RXIEN,2,"I") Q:'PSODFN
S PSOLST(1)=52_U_RXIEN_U_$$GET1^DIQ(52,RXIEN,100,"E")
S ORN=1
S PSOOPT=0
D OERR^PSOCAN3(NERXIEN)
S PSTAT=$$GET1^DIQ(52,RXIEN,100,"I")
I PSTAT<12!(PSTAT>15) D Q
.I '$L($G(VALMSG)) S VALMSG="eRx auto-discontinue failed."
.I RTYPE="R" D UPDSTAT^PSOERXU1(ERXIEN,"RXE",$G(VALMSG))
.I RTYPE'="R" D UPDSTAT^PSOERXU1(ERXIEN,"RXF",$G(VALMSG))
.I MTYPE="RE",REQIEN,$$GET1^DIQ(52.49,REQIEN,.08,"I")'="RRR" D UPDSTAT^PSOERXU1(REQIEN,"RRR",$G(VALMSG))
.S ERRSEQ=$$ERRSEQ^PSOERXU1(ERXIEN) Q:'ERRSEQ
.D FILERR^PSOERXU1(ERXIENS,ERRSEQ,"PX","V",$G(VALMSG))
.I MTYPE="CX" D Q
..D UPDSTAT^PSOERXU1(ERXIEN,"CXE",$G(VALMSG))
..I REQIEN,$$GET1^DIQ(52.49,REQIEN,1,"E")'="CRR" D UPDSTAT^PSOERXU1(REQIEN,"CRR",$G(VALMSG))
I MTYPE="CX",(RTYPE="A"!(RTYPE="AWC")!(RTYPE="V")) D Q
.D UPDSTAT^PSOERXU1(NERXIEN,"CXQ")
.I $$GET1^DIQ(52.49,REQIEN,1,"E")'="CRR" D UPDSTAT^PSOERXU1(REQIEN,"CRR")
I MTYPE="RE",RTYPE="R" D Q
.D UPDSTAT^PSOERXU1(ERXIEN,"RXR")
.I REQIEN D UPDSTAT^PSOERXU1(REQIEN,"RRR")
D UPDSTAT^PSOERXU1(ERXIEN,"RXD")
I REQIEN,$$GET1^DIQ(52.49,REQIEN,.08,"I")="RR" D UPDSTAT^PSOERXU1(REQIEN,"RRP")
Q
; screen out options that do not apply to refill request or refill response
RRRESCR(ERXIEN,OPT) ;
N MTYPE,REFREQ,REFRES,OK,DELTAS,RESTYPE,ERXSTAT,MESREQ
S OK=1
S MTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
S RESTYPE=$$GET1^DIQ(52.49,ERXIEN,52.1,"I")
S MESREQ=$$GET1^DIQ(52.49,ERXIEN,315.1,"I")
S ERXSTAT=$$GET1^DIQ(52.49,ERXIEN,1,"E")
I MTYPE="CX" D Q OK
.I $E(RESTYPE)="V" S OK=1 Q
.I $E(RESTYPE)'="A",",G,T,S,OS,D,"'[MESREQ S OK=0
I MTYPE="RR"!(MTYPE="CA")!(MTYPE="CN") S OK=0 Q OK
; if this is a refill response, and we are screening the provider action
I MTYPE="RE" D Q OK
.; THESE 3 LINES ARE FOR REPLACE TYPE RENEWAL REQUEST UNLOCKS ON VALIDATION ACTIONS
.I '$D(OPT),RESTYPE="R" S OK=1 Q
.I '$D(OPT) S OK=0 Q
.I OPT="ACCEPT",RESTYPE="R",ERXSTAT="RXW"!(ERXSTAT="RXI") S OK=1 Q
.I OPT="PROVIDER",RESTYPE="R","RXP,RXC"'[ERXSTAT S OK=1 Q
.I OPT="DRUG",RESTYPE="R","RXP,RXC"'[ERXSTAT S OK=1 Q
.I '$D(OPT) S OK=0 Q
.I $$GET1^DIQ(52.49,ERXIEN,52.1,"I")["D" S OK=0 Q
.I "RXP,RXC,RXF,RXE"[$$GET1^DIQ(52.49,ERXIEN,1,"E") S OK=0 Q
.S REFRES=ERXIEN,REFREQ=$$RESOLV^PSOERXU2(ERXIEN)
.I 'REFREQ!('REFRES) S OK=0 Q
.D RRDELTA^PSOERXU2(.DELTAS,REFREQ,REFRES)
.I OPT="PROVIDER",$D(DELTAS(52.49,"EXTERNAL PROVIDER")),'$$GET1^DIQ(52.49,ERXIEN,.13,"I") S OK=1
.; if there were changes to the provider, user will need to revalidate and accept
.; only unlock if there were deltas on the provider and the provider has been validated on this message
.I OPT="ACCEPT",'$D(DELTAS(52.49,"EXTERNAL PROVIDER")) S OK=0 Q
.I OPT="ACCEPT",$D(DELTAS(52.49,"EXTERNAL PROVIDER")),$$GET1^DIQ(52.49,ERXIEN,1.3,"I"),'$$GET1^DIQ(52.49,ERXIEN,.13,"I") S OK=1
.; if changes are in the drug segment only, no validations or other pharmacist actions needed
.I OPT="DRUG" S OK=0
I MTYPE="RE",OPT="DRUG" S OK=0 Q OK
Q OK
;
;Process refill response into pending outpatient orders
PREFRES(PSOIEN,PSOHY,PSOEXCNT,PSOEXMS,PSODAT) ;
N REQIEN,ORXIEN,PROVIEN,VADRG,PRMVAL,DMVAL,PMVAL,RXIEN,RESTYPE,DELTA,PSOIENS
S PSOIENS=PSOIEN_","
S RESTYPE=$$GET1^DIQ(52.49,PSOIEN,52.1,"I")
S REQIEN=$$RESOLV^PSOERXU2(PSOIEN) I REQIEN S ORXIEN=$$RESOLV^PSOERXU2(REQIEN)
I '$G(ORXIEN) S PSOEXCNT=PSOEXCNT+1,PSOEXMS(PSOEXCNT)="Could not resolve original eRx. Cannot process response." Q
S RXIEN=$$GET1^DIQ(52.49,ORXIEN,.13,"I") I 'RXIEN S PSOEXCNT=PSOEXCNT+1,PSOEXMS(PSOEXCNT)="Could not resolve original eRx. Cannot process response." Q
I RESTYPE="A" D PSOHY(.PSOHY,PSOIEN,ORXIEN,RXIEN) Q
; process 'approved with changes' response types
; if this refill response has any validations/linkages, use them. Otherwise, use the validations/linkages from the original (new) rx.
D RRDELTA^PSOERXU2(.DELTA,REQIEN,PSOIEN)
S PROVIEN=""
I $D(DELTA(52.49,"EXTERNAL PROVIDER")) D
.S PROVIEN=$G(PSODAT(F,PSOIENS,2.3,"I")) ; response message provider IEN
.I 'PROVIEN S PSOEXCNT=PSOEXCNT+1,PSOEXMS(PSOEXCNT)="Provider not linked. Cannot process renewal request." Q
.; if the provider or drug has been linked, then a change has occured in one of those segments, so they must be validated
.S PRMVAL=$G(PSODAT(F,PSOIENS,1.3,"I")) I 'PRMVAL S PSOEXCNT=PSOEXCNT+1,PSOEXMS(PSOEXCNT)="Provider not validated. Cannot process renewal request." Q
Q:$O(PSOEXMS(0))
D PSOHY(.PSOHY,PSOIEN,ORXIEN,RXIEN,PROVIEN) Q
Q
; ERXIEN - refill response IEN from 52.49
; ORXIEN - newRx IEN from 52.49
; RXIEN - prescription entry from file #52
; PROVOVR - provider override, when approved with changes included a change to the provider
PSOHY(PSOHY,ERXIEN,ORXIEN,RXIEN,PROVOVR) ;
N RXDAT,ERXRFLS,ERXWDATE,LOC,ERXNUM,RXIENS,VAROUT,PROVIEN,EFFDT,VAOI,VADRUG,VAREF,PATIEN,VAPRIOR,ORDERTYP,VADAYS,VQTY
N WRITDT,SLOOP,SCNT,SLOOP2
S RXIENS=RXIEN_","
S ERXNUM=$$GET1^DIQ(52.49,ERXIEN,.01,"E")
D GETS^DIQ(52,RXIEN,"**","IE","RXDAT")
S LOC=$G(RXDAT(52,RXIENS,5,"I"))
S VAROUT=$G(RXDAT(52,RXIENS,11,"I"))
S PROVIEN=$S($G(PROVOVR):PROVOVR,1:$G(RXDAT(52,RXIENS,4,"I")))
; effective date CANNOT be null.. make sure it is set to something. written date is the first fall back, then todays date
S EFFDT=$$GET1^DIQ(52.49,ERXIEN,6.3,"I") I 'EFFDT S EFFDT=$$GET1^DIQ(52.49,ERXIEN,5.9,"I")
I 'EFFDT S EFFDT=DT
S VAOI=$G(RXDAT(52,RXIENS,39.2,"I"))
S VQTY=$G(RXDAT(52,RXIENS,7,"E"))
S VADRUG=$G(RXDAT(52,RXIENS,6,"I"))
; always decrement 1 from # of refills, because refills is actually total # of fills.
S VAREF=$$GET1^DIQ(52.49,ERXIEN,5.6,"E")
I VAREF>0 S VAREF=VAREF-1
S PATIEN=$G(RXDAT(52,RXIENS,2,"I"))
; for now, set priority to routine
S VAPRIOR="R"
S VADAYS=$G(RXDAT(52,RXIENS,8,"E"))
S WRITDT=$$GET1^DIQ(52.49,ERXIEN,5.9,"I")
S ORDERTYP="RNW"
S PSOHY("PREVORD")=RXIEN
S PSOHY("LOC")=LOC,PSOHY("CHNUM")=$G(ERXNUM)
S PSOHY("PICK")=VAROUT,PSOHY("ENTER")=PROVIEN
S PSOHY("PROV")=PROVIEN,PSOHY("SDT")=EFFDT
S PSOHY("ITEM")=VAOI,PSOHY("DRUG")=VADRUG
S PSOHY("QTY")=VQTY,PSOHY("REF")=VAREF
; DFN cannot be newed/killed here because it needs to exist for the subsequent call.
S (PSOHY("PAT"),DFN)=PATIEN,PSOHY("OCC")=ORDERTYP
; Login date will always be the Message Received Date/Time
S PSOHY("EDT")=$$GET1^DIQ(52.49,ERXIEN,.03,"I"),PSOHY("PRIOR")=VAPRIOR
; ALWAYS PSO as the external application
S PSOHY("EXAPP")="PHARMACY"
S PSOHY("DAYS")=VADAYS
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOERXU3 16808 printed Apr 09, 2024@21:38:21 Page 2
PSOERXU3 ;ALB/BWF - eRx utilities ; 5/26/2017 9:57am
+1 ;;7.0;OUTPATIENT PHARMACY;**508,591,606,581,617,646,700**;DEC 1997;Build 261
+2 ;
+3 QUIT
+4 ; PSO*508 - Added MEDDIS, RRREQ, and RRRES linetags.
+5 ; ERXIEN - IEN FROM 52.49
+6 ; DTYPE - R for REQUESTED, or D for dispensed drugs
MEDDIS(ERXIEN,DTYPE,LINE) ;
+1 NEW DRUG,DIEN,QTY,DAYS,WDATE,EFDATE,REFILL,EXDATE,LFDATE,DIRECT,CLQ,USC,PUC,F,IENS,I,LTXT
+2 NEW RXIEN,RXNUM,INS,DDAT,PARIEN,OREFILL,DLOOP,DIRARY,MTYPE,QUOM
+3 SET F=52.4949
+4 SET MTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
+5 SET LINE=LINE+1
DO SET^VALM10(LINE,"")
+6 SET LINE=LINE+1
DO SET^VALM10(LINE,"****************************MEDICATION DISPENSED****************************")
+7 SET PARIEN=$$RESOLV^PSOERXU2(ERXIEN)
+8 IF PARIEN
SET RXIEN=$$GET1^DIQ(52.49,PARIEN,.13,"I")
+9 IF PARIEN
SET QUOM=$$GET1^DIQ(52.49,PARIEN,5.4,"E")
+10 IF $EXTRACT($GET(QUOM))="C"
SET QUOM=$$CODERES^PSOERXU7(QUOM,"NCI")
+11 IF $GET(RXIEN)
SET OREFILL=$$GET1^DIQ(52,RXIEN,9,"E")
+12 SET I=0
FOR
SET I=$ORDER(^PS(52.49,ERXIEN,49,I))
if 'I
QUIT
Begin DoDot:1
+13 SET IENS=I_","_ERXIEN_","
+14 ;Q:$$GET1^DIQ(F,IENS,.02,"I")'=DTYPE
+15 DO GETS^DIQ(F,IENS,"**","IE","DDAT")
+16 SET DRUG=$GET(DDAT(F,IENS,.01,"E"))
+17 SET DIEN=$GET(DDAT(F,IENS,.03,"I"))
+18 SET QTY=$GET(DDAT(F,IENS,.04,"E"))
+19 SET DAYS=$GET(DDAT(F,IENS,.05,"E"))
+20 SET REFILL=$GET(DDAT(F,IENS,.06,"E"))
+21 SET DIRECT=$GET(DDAT(F,IENS,1,"E"))
+22 SET WDATE=$GET(DDAT(F,IENS,2.1,"E"))
+23 SET LFDATE=$GET(DDAT(F,IENS,2.2,"E"))
+24 SET EXDATE=$GET(DDAT(F,IENS,2.3,"E"))
+25 SET EFDATE=$GET(DDAT(F,IENS,2.4,"E"))
+26 SET CLQ=$GET(DDAT(F,IENS,2.5,"E"))
+27 SET USC=$GET(DDAT(F,IENS,2.6,"E"))
+28 SET PUC=$GET(DDAT(F,IENS,2.7,"E"))
+29 ; if there is an RX ien, reset the refills to that value - may need to adjust other fields as well
+30 IF $GET(RXIEN)
SET REFILL=$$GET1^DIQ(52,RXIEN,9,"E")
+31 SET LINE=LINE+1
DO SET^VALM10(LINE,"Vista Drug: "_DRUG_" "_$PIECE($$VADRSCH^PSOERXUT(+$GET(DIEN)),"^",3))
+32 SET LINE=LINE+1
+33 DO ADDITEM^PSOERX1A(.LTXT,"Vista Qty: ",$GET(QTY),1,25)
+34 DO ADDITEM^PSOERX1A(.LTXT,"Vista Refills: ",$GET(REFILL),27,18)
+35 DO ADDITEM^PSOERX1A(.LTXT,"Vista Days Supply: ",$GET(DAYS),54,22)
+36 DO SET^VALM10(LINE,LTXT)
SET LTXT=""
+37 SET LINE=LINE+1
DO SET^VALM10(LINE,"Quantity Unit of Measure: "_$GET(QUOM))
+38 SET DIRECT="Vista Sig: "_DIRECT
+39 DO TXT2ARY^PSOERXD1(.DIRARY,DIRECT," ",75)
+40 SET DLOOP=0
FOR
SET DLOOP=$ORDER(DIRARY(DLOOP))
if 'DLOOP
QUIT
Begin DoDot:2
+41 SET LINE=LINE+1
+42 DO SET^VALM10(LINE,$GET(DIRARY(DLOOP)))
End DoDot:2
End DoDot:1
+43 IF $GET(RXIEN)
Begin DoDot:1
+44 SET RXNUM=$$GET1^DIQ(52,RXIEN,.01,"E")
+45 SET INS=0
FOR
SET INS=$ORDER(^PSRX(RXIEN,"INS1",INS))
if 'INS
QUIT
Begin DoDot:2
+46 SET LINE=LINE+1
DO SET^VALM10(LINE,"Pat Inst: "_$$GET1^DIQ(52.0115,INS_","_RXIEN_",",.01,"E"))
End DoDot:2
End DoDot:1
+47 IF '$LENGTH($GET(RXNUM))
SET RXNUM="Unable to resolve."
+48 SET LINE=LINE+1
DO SET^VALM10(LINE,"VA Rx#: "_$GET(RXNUM))
+49 QUIT
+50 ; refill request information
RRREQ(ERXIEN,LINE) ;
+1 NEW REQBY,REQDTTM,REFREQ,COMM,COMMARY,I,COMMBY,COMMDTTM,CTXT,REQIEN,S2017
+2 SET REQIEN=ERXIEN
+3 IF $$GET1^DIQ(52.49,ERXIEN,.08,"I")="RE"
SET REQIEN=$$RESOLV^PSOERXU2(ERXIEN)
+4 SET REQBY=$$GET1^DIQ(52.49,REQIEN,51.1,"E")
+5 SET REFREQ=$$GET1^DIQ(52.49,REQIEN,51.2,"E")
+6 SET REQDTTM=$$GET1^DIQ(52.49,REQIEN,.03,"E")
+7 SET COMM=$$GET1^DIQ(52.49,REQIEN,50,"E")
+8 SET S2017=$$GET1^DIQ(52.49,ERXIEN,312.1)
+9 SET LINE=LINE+1
DO SET^VALM10(LINE,"")
+10 SET LINE=LINE+1
DO SET^VALM10(LINE,"************************RXRENEWAL REQUEST INFORMATION**************************")
+11 SET LINE=LINE+1
DO SET^VALM10(LINE,"Requested By: "_REQBY)
+12 SET LINE=LINE+1
DO SET^VALM10(LINE,"Request Date/Time: "_REQDTTM)
+13 SET LINE=LINE+1
DO SET^VALM10(LINE,"# of Refills Requested: "_REFREQ)
+14 SET LINE=LINE+1
DO SET^VALM10(LINE,"")
+15 SET COMM="RxRenewal Request Comments: "_COMM
+16 DO TXT2ARY^PSOERXD1(.COMMARY,COMM," ",80)
+17 SET I=0
FOR
SET I=$ORDER(COMMARY(I))
if 'I
QUIT
Begin DoDot:1
+18 SET CTXT=$GET(COMMARY(I))
+19 SET LINE=LINE+1
DO SET^VALM10(LINE,CTXT)
End DoDot:1
+20 SET COMMBY=$$GET1^DIQ(52.49,REQIEN,50.1,"E")
+21 SET COMMDTTM=$$GET1^DIQ(52.49,REQIEN,50.2,"E")
+22 SET LINE=LINE+1
DO SET^VALM10(LINE,"Comments By: "_COMMBY)
+23 SET LINE=LINE+1
DO SET^VALM10(LINE,"Comments Date/Time: "_COMMDTTM)
+24 QUIT
+25 ;
MSGHIS(ERXIEN,LINE) ;
+1 NEW FLAG
+2 SET FLAG=+$GET(FLAG)
+3 NEW ERXREF,RELERX,ERXRES,I,ERXHID,FOUND,REQID,RESID,MTYPE
+4 SET MTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
+5 IF ",RR,CA,CR,"[(","_MTYPE_",")
SET REQIEN=ERXIEN
SET RESIEN=$$GETRESP^PSOERXU2(ERXIEN)
+6 IF ",RE,CN,CX,"[(","_MTYPE_",")
SET RESIEN=ERXIEN
SET REQIEN=$$RESOLV^PSOERXU2(ERXIEN)
+7 IF MTYPE="IE"
SET RESIEN=ERXIEN
SET REQIEN=$$RESOLV^PSOERXU2(ERXIEN)
+8 SET RESID=$$GET1^DIQ(52.49,RESIEN,.01,"E")
+9 SET REQID=$$GET1^DIQ(52.49,REQIEN,.01,"E")
+10 SET RELERX=$$GET1^DIQ(52.49,REQIEN,.14)
+11 SET FOUND=0
+12 SET I=ERXIEN
FOR
SET I=$ORDER(^PS(52.49,ERXIEN,201,"B",I))
if 'I!(FOUND)
QUIT
Begin DoDot:1
+13 IF $$GET1^DIQ(52.49,I,.08,"E")="RE"
IF $$GET1^DIQ(52.49,I,.14,"E")=$$GET1^DIQ(52.49,ERXIEN,.01,"E")
SET ERXRES=$$GET1^DIQ(52.49,I,.14,"E")
SET FOUND=1
End DoDot:1
+14 SET LINE=LINE+1
DO SET^VALM10(LINE,"")
+15 SET LINE=LINE+1
DO SET^VALM10(LINE,"*****************************MESSAGE HISTORY********************************")
+16 SET LINE=LINE+1
DO SET^VALM10(LINE,"Request Reference #: "_$GET(REQID))
+17 SET LINE=LINE+1
DO SET^VALM10(LINE,"New eRx Reference #: "_RELERX)
+18 SET LINE=LINE+1
DO SET^VALM10(LINE,"Response eRx Reference #: "_$GET(RESID))
+19 QUIT
+20 ; refill response information
RRRES(ERXIEN,LINE,PMODE) ;p646 added PMODE parameter.
+1 ; If PMODE is greater than 0 then the video control calls will be utilized.
+2 NEW RESVAL,RESNOTE,I,RESCODE,RESDTTM,RESDESC,ERXDAT,IENS,RESIEN,RECODE,RESTEXT,MTYPE,REQIEN,CODEIEN
+3 NEW STR1ARY,STR2ARY,J,STR1,STR2,DELTA,FN,COMM,COMMARY,COMMBY,COMMDTTM,ERESCODE,S2017,REQS2017,RESS2017
+4 SET MTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
+5 IF MTYPE="RE"!(MTYPE="CN")
SET RESIEN=ERXIEN
SET REQIEN=$$RESOLV^PSOERXU2(ERXIEN)
+6 IF MTYPE="RR"!(MTYPE="CA")
SET REQIEN=ERXIEN
SET RESIEN=$$GETRESP^PSOERXU2(ERXIEN)
if 'RESIEN
QUIT
+7 SET REQS2017=$$GET1^DIQ(52.49,REQIEN,312.1)
+8 SET RESS2017=$$GET1^DIQ(52.49,RESIEN,312.1)
+9 SET IENS=RESIEN_","
+10 DO GETS^DIQ(52.49,RESIEN,".03;.13;52.1;52.2;52.3","IE","ERXDAT")
+11 SET RESVAL=$GET(ERXDAT(52.49,IENS,52.1,"E"))
+12 SET RESCODE=$GET(ERXDAT(52.49,IENS,52.1,"I"))
+13 SET RESNOTE=$GET(ERXDAT(52.49,IENS,52.2,"E"))
+14 SET RESDTTM=$GET(ERXDAT(52.49,IENS,.03,"E"))
+15 SET LINE=LINE+1
DO SET^VALM10(LINE,"")
+16 SET LINE=LINE+1
DO SET^VALM10(LINE,"************************RXRENEWAL RESPONSE INFORMATION**************************")
+17 SET LINE=LINE+1
DO SET^VALM10(LINE,RESVAL)
if $GET(PMODE)
DO CNTRL^VALM10(LINE,1,$LENGTH(RESVAL),IORVON,IORVOFF)
+18 SET LINE=LINE+1
DO SET^VALM10(LINE,"Response Date/Time: "_RESDTTM)
+19 SET LINE=LINE+1
DO SET^VALM10(LINE,"Note: "_RESNOTE)
+20 SET LINE=LINE+1
DO SET^VALM10(LINE,"")
+21 SET COMM=$$GET1^DIQ(52.49,RESIEN,50,"E")
+22 SET COMM="RxRenewal Response Comments: "_COMM
+23 DO TXT2ARY^PSOERXD1(.COMMARY,COMM," ",80)
+24 SET I=0
FOR
SET I=$ORDER(COMMARY(I))
if 'I
QUIT
Begin DoDot:1
+25 SET CTXT=$GET(COMMARY(I))
+26 SET LINE=LINE+1
DO SET^VALM10(LINE,CTXT)
End DoDot:1
+27 SET COMMBY=$$GET1^DIQ(52.49,RESIEN,50.1,"E")
+28 SET COMMDTTM=$$GET1^DIQ(52.49,RESIEN,50.2,"E")
+29 SET LINE=LINE+1
DO SET^VALM10(LINE,"Comments By: "_COMMBY)
+30 SET LINE=LINE+1
DO SET^VALM10(LINE,"Comments Date/Time: "_COMMDTTM)
+31 SET LINE=LINE+1
DO SET^VALM10(LINE,"")
+32 SET I=0
FOR
SET I=$ORDER(^PS(52.49,RESIEN,55,I))
if 'I
QUIT
Begin DoDot:1
+33 SET ERESCODE=$$GET1^DIQ(52.4955,I_","_IENS,.01,"E")
+34 SET CODEIEN=$$GET1^DIQ(52.4955,I_","_IENS,.01,"I")
+35 SET RESDESC=$$GET1^DIQ(52.45,CODEIEN,.02,"E")
+36 SET RESTEXT=RESVAL_" reason code: "_ERESCODE
+37 SET LINE=LINE+1
DO SET^VALM10(LINE,RESTEXT)
if $GET(PMODE)
DO CNTRL^VALM10(LINE,1,$LENGTH(RESTEXT),IORVON,IORVOFF)
+38 SET LINE=LINE+1
DO SET^VALM10(LINE,"Code Description: "_RESDESC)
+39 SET LINE=LINE+1
DO SET^VALM10(LINE,"")
End DoDot:1
+40 IF '$GET(REQS2017)
IF '$GET(RESS2017)
Begin DoDot:1
+41 IF RESCODE="AWC"!(RESCODE="A")
Begin DoDot:2
+42 DO RRDELTA^PSOERXU2(.DELTA,REQIEN,RESIEN)
if '$DATA(DELTA)
QUIT
+43 SET LINE=LINE+1
DO SET^VALM10(LINE,"********************************CHANGED ITEMS***********************************")
+44 SET I=0
FOR
SET I=$ORDER(DELTA(I))
if 'I
QUIT
Begin DoDot:3
+45 SET FN=""
FOR
SET FN=$ORDER(DELTA(I,FN))
if FN=""
QUIT
Begin DoDot:4
+46 KILL STR1ARY,STR2ARY
+47 SET LINE=LINE+1
DO SET^VALM10(LINE,"Field: "_FN)
if $GET(PMODE)
DO CNTRL^VALM10(LINE,1,$LENGTH(FN)+7,IORVON,IORVOFF)
+48 SET STR1="RxRenewal Request Value : "_$PIECE(DELTA(I,FN),U)
+49 DO TXT2ARY^PSOERXD1(.STR1ARY,STR1," ",78)
+50 SET STR2="RxRenewal Response Value : "_$PIECE(DELTA(I,FN),U,2)
+51 DO TXT2ARY^PSOERXD1(.STR2ARY,STR2," ",78)
+52 SET J=0
FOR
SET J=$ORDER(STR1ARY(J))
if 'J
QUIT
Begin DoDot:5
+53 SET LINE=LINE+1
DO SET^VALM10(LINE," "_$GET(STR1ARY(J)))
End DoDot:5
+54 SET J=0
FOR
SET J=$ORDER(STR2ARY(J))
if 'J
QUIT
Begin DoDot:5
+55 SET LINE=LINE+1
DO SET^VALM10(LINE," "_$GET(STR2ARY(J)))
End DoDot:5
+56 SET LINE=LINE+1
DO SET^VALM10(LINE,"")
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+57 QUIT
ERRDISP(ERXIEN,LINE) ;
+1 DO ERRDISP^PSOERXU7(ERXIEN,.LINE)
+2 QUIT
+3 ; displays processing errors
PROCERR(ERXIEN,LINE) ;
+1 NEW ERRIEN,ERRIENS,ERRTXT,ERRTARY
+2 ; quit if there are no processing errors
+3 if '$DATA(^PS(52.49,ERXIEN,100,"C","PX"))
QUIT
+4 SET LINE=LINE+1
DO SET^VALM10(LINE,"")
+5 SET LINE=LINE+1
DO SET^VALM10(LINE,"****************************PROCESSING ERRORS*******************************")
+6 SET ERRIEN=0
FOR
SET ERRIEN=$ORDER(^PS(52.49,ERXIEN,100,ERRIEN))
if 'ERRIEN
QUIT
Begin DoDot:1
+7 SET ERRIENS=ERRIEN_","_ERXIEN_","
+8 SET ERRTXT=$$GET1^DIQ(52.49101,ERRIENS,1,"E")
+9 SET ERRTXT="Error Details: "_ERRTXT
+10 DO TXT2ARY^PSOERXD1(.ERRTARY,ERRTXT," ",78)
+11 SET I=0
FOR
SET I=$ORDER(ERRTARY(I))
if 'I
QUIT
Begin DoDot:2
+12 SET LINE=LINE+1
DO SET^VALM10(LINE,$GET(ERRTARY(I)))
End DoDot:2
+13 KILL ERRTXT,ERRTARY
End DoDot:1
+14 QUIT
+15 ; automatically DC a prescription if a denied, new prescription to follow is recieved
AUTODC(ERXIEN) ;
+1 NEW PSODFN,RXIEN,PSOLST,ORN,PSOOPT,PSOSITE,PSODIV,PSOSYS,PSODIV,PSOSYS,NERXIEN
+2 NEW RTYPE,REQIEN,ERRSEQ,VALMSG,ERXIENS,RXSTAT,PSTAT,MTYPE
+3 if 'ERXIEN
QUIT
+4 SET ERXIENS=ERXIEN_","
+5 ; get the RXIEN
+6 SET REQIEN=$$RESOLV^PSOERXU2(ERXIEN)
+7 IF REQIEN
SET NERXIEN=$$RESOLV^PSOERXU2(REQIEN)
+8 SET MTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
+9 SET RTYPE=$$GET1^DIQ(52.49,ERXIEN,52.1,"I")
+10 ; if for some reason the newrx could not be identified, there is no way we can auto-dc, so quit
+11 if '$PIECE($GET(NERXIEN),U)
QUIT
+12 SET RXIEN=$$GET1^DIQ(52.49,NERXIEN,.13,"I")
if RXIEN=""
QUIT
+13 ; if already DC'd, do not try to DC again
+14 SET RXSTAT=$$GET1^DIQ(52,RXIEN,100,"I")
+15 IF (RXSTAT=12)!(RXSTAT=14)!(RXSTAT=15)
Begin DoDot:1
+16 SET ERRSEQ=$$ERRSEQ^PSOERXU1(ERXIEN)
if 'ERRSEQ
QUIT
+17 SET VALMSG="eRx auto-discontinue failed. Prescription is already discontinued."
+18 DO FILERR^PSOERXU1(ERXIENS,ERRSEQ,"PX","V",$GET(VALMSG))
+19 IF MTYPE="CX"
Begin DoDot:2
+20 DO UPDSTAT^PSOERXU1(ERXIEN,"CXE",$GET(VALMSG))
+21 IF REQIEN
IF $$GET1^DIQ(52.49,REQIEN,1,"E")'="CRR"
DO UPDSTAT^PSOERXU1(REQIEN,"CRR",$GET(VALMSG))
End DoDot:2
QUIT
+22 IF REQIEN
IF $$GET1^DIQ(52.49,REQIEN,1,"E")'="RRR"
DO UPDSTAT^PSOERXU1(REQIEN,"RRR",$GET(VALMSG))
+23 IF RTYPE="R"
DO UPDSTAT^PSOERXU1(ERXIEN,"RXE",$GET(VALMSG))
QUIT
+24 DO UPDSTAT^PSOERXU1(ERXIEN,"RXF",$GET(VALMSG))
End DoDot:1
QUIT
+25 SET PSOSITE=$$GET1^DIQ(52,RXIEN,20,"I")
+26 SET PSOSYS=$GET(^PS(59.7,1,40.1))
if PSOSYS=""
QUIT
+27 SET PSODFN=$$GET1^DIQ(52,RXIEN,2,"I")
if 'PSODFN
QUIT
+28 SET PSOLST(1)=52_U_RXIEN_U_$$GET1^DIQ(52,RXIEN,100,"E")
+29 SET ORN=1
+30 SET PSOOPT=0
+31 DO OERR^PSOCAN3(NERXIEN)
+32 SET PSTAT=$$GET1^DIQ(52,RXIEN,100,"I")
+33 IF PSTAT<12!(PSTAT>15)
Begin DoDot:1
+34 IF '$LENGTH($GET(VALMSG))
SET VALMSG="eRx auto-discontinue failed."
+35 IF RTYPE="R"
DO UPDSTAT^PSOERXU1(ERXIEN,"RXE",$GET(VALMSG))
+36 IF RTYPE'="R"
DO UPDSTAT^PSOERXU1(ERXIEN,"RXF",$GET(VALMSG))
+37 IF MTYPE="RE"
IF REQIEN
IF $$GET1^DIQ(52.49,REQIEN,.08,"I")'="RRR"
DO UPDSTAT^PSOERXU1(REQIEN,"RRR",$GET(VALMSG))
+38 SET ERRSEQ=$$ERRSEQ^PSOERXU1(ERXIEN)
if 'ERRSEQ
QUIT
+39 DO FILERR^PSOERXU1(ERXIENS,ERRSEQ,"PX","V",$GET(VALMSG))
+40 IF MTYPE="CX"
Begin DoDot:2
+41 DO UPDSTAT^PSOERXU1(ERXIEN,"CXE",$GET(VALMSG))
+42 IF REQIEN
IF $$GET1^DIQ(52.49,REQIEN,1,"E")'="CRR"
DO UPDSTAT^PSOERXU1(REQIEN,"CRR",$GET(VALMSG))
End DoDot:2
QUIT
End DoDot:1
QUIT
+43 IF MTYPE="CX"
IF (RTYPE="A"!(RTYPE="AWC")!(RTYPE="V"))
Begin DoDot:1
+44 DO UPDSTAT^PSOERXU1(NERXIEN,"CXQ")
+45 IF $$GET1^DIQ(52.49,REQIEN,1,"E")'="CRR"
DO UPDSTAT^PSOERXU1(REQIEN,"CRR")
End DoDot:1
QUIT
+46 IF MTYPE="RE"
IF RTYPE="R"
Begin DoDot:1
+47 DO UPDSTAT^PSOERXU1(ERXIEN,"RXR")
+48 IF REQIEN
DO UPDSTAT^PSOERXU1(REQIEN,"RRR")
End DoDot:1
QUIT
+49 DO UPDSTAT^PSOERXU1(ERXIEN,"RXD")
+50 IF REQIEN
IF $$GET1^DIQ(52.49,REQIEN,.08,"I")="RR"
DO UPDSTAT^PSOERXU1(REQIEN,"RRP")
+51 QUIT
+52 ; screen out options that do not apply to refill request or refill response
RRRESCR(ERXIEN,OPT) ;
+1 NEW MTYPE,REFREQ,REFRES,OK,DELTAS,RESTYPE,ERXSTAT,MESREQ
+2 SET OK=1
+3 SET MTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
+4 SET RESTYPE=$$GET1^DIQ(52.49,ERXIEN,52.1,"I")
+5 SET MESREQ=$$GET1^DIQ(52.49,ERXIEN,315.1,"I")
+6 SET ERXSTAT=$$GET1^DIQ(52.49,ERXIEN,1,"E")
+7 IF MTYPE="CX"
Begin DoDot:1
+8 IF $EXTRACT(RESTYPE)="V"
SET OK=1
QUIT
+9 IF $EXTRACT(RESTYPE)'="A"
IF ",G,T,S,OS,D,"'[MESREQ
SET OK=0
End DoDot:1
QUIT OK
+10 IF MTYPE="RR"!(MTYPE="CA")!(MTYPE="CN")
SET OK=0
QUIT OK
+11 ; if this is a refill response, and we are screening the provider action
+12 IF MTYPE="RE"
Begin DoDot:1
+13 ; THESE 3 LINES ARE FOR REPLACE TYPE RENEWAL REQUEST UNLOCKS ON VALIDATION ACTIONS
+14 IF '$DATA(OPT)
IF RESTYPE="R"
SET OK=1
QUIT
+15 IF '$DATA(OPT)
SET OK=0
QUIT
+16 IF OPT="ACCEPT"
IF RESTYPE="R"
IF ERXSTAT="RXW"!(ERXSTAT="RXI")
SET OK=1
QUIT
+17 IF OPT="PROVIDER"
IF RESTYPE="R"
IF "RXP,RXC"'[ERXSTAT
SET OK=1
QUIT
+18 IF OPT="DRUG"
IF RESTYPE="R"
IF "RXP,RXC"'[ERXSTAT
SET OK=1
QUIT
+19 IF '$DATA(OPT)
SET OK=0
QUIT
+20 IF $$GET1^DIQ(52.49,ERXIEN,52.1,"I")["D"
SET OK=0
QUIT
+21 IF "RXP,RXC,RXF,RXE"[$$GET1^DIQ(52.49,ERXIEN,1,"E")
SET OK=0
QUIT
+22 SET REFRES=ERXIEN
SET REFREQ=$$RESOLV^PSOERXU2(ERXIEN)
+23 IF 'REFREQ!('REFRES)
SET OK=0
QUIT
+24 DO RRDELTA^PSOERXU2(.DELTAS,REFREQ,REFRES)
+25 IF OPT="PROVIDER"
IF $DATA(DELTAS(52.49,"EXTERNAL PROVIDER"))
IF '$$GET1^DIQ(52.49,ERXIEN,.13,"I")
SET OK=1
+26 ; if there were changes to the provider, user will need to revalidate and accept
+27 ; only unlock if there were deltas on the provider and the provider has been validated on this message
+28 IF OPT="ACCEPT"
IF '$DATA(DELTAS(52.49,"EXTERNAL PROVIDER"))
SET OK=0
QUIT
+29 IF OPT="ACCEPT"
IF $DATA(DELTAS(52.49,"EXTERNAL PROVIDER"))
IF $$GET1^DIQ(52.49,ERXIEN,1.3,"I")
IF '$$GET1^DIQ(52.49,ERXIEN,.13,"I")
SET OK=1
+30 ; if changes are in the drug segment only, no validations or other pharmacist actions needed
+31 IF OPT="DRUG"
SET OK=0
End DoDot:1
QUIT OK
+32 IF MTYPE="RE"
IF OPT="DRUG"
SET OK=0
QUIT OK
+33 QUIT OK
+34 ;
+35 ;Process refill response into pending outpatient orders
PREFRES(PSOIEN,PSOHY,PSOEXCNT,PSOEXMS,PSODAT) ;
+1 NEW REQIEN,ORXIEN,PROVIEN,VADRG,PRMVAL,DMVAL,PMVAL,RXIEN,RESTYPE,DELTA,PSOIENS
+2 SET PSOIENS=PSOIEN_","
+3 SET RESTYPE=$$GET1^DIQ(52.49,PSOIEN,52.1,"I")
+4 SET REQIEN=$$RESOLV^PSOERXU2(PSOIEN)
IF REQIEN
SET ORXIEN=$$RESOLV^PSOERXU2(REQIEN)
+5 IF '$GET(ORXIEN)
SET PSOEXCNT=PSOEXCNT+1
SET PSOEXMS(PSOEXCNT)="Could not resolve original eRx. Cannot process response."
QUIT
+6 SET RXIEN=$$GET1^DIQ(52.49,ORXIEN,.13,"I")
IF 'RXIEN
SET PSOEXCNT=PSOEXCNT+1
SET PSOEXMS(PSOEXCNT)="Could not resolve original eRx. Cannot process response."
QUIT
+7 IF RESTYPE="A"
DO PSOHY(.PSOHY,PSOIEN,ORXIEN,RXIEN)
QUIT
+8 ; process 'approved with changes' response types
+9 ; if this refill response has any validations/linkages, use them. Otherwise, use the validations/linkages from the original (new) rx.
+10 DO RRDELTA^PSOERXU2(.DELTA,REQIEN,PSOIEN)
+11 SET PROVIEN=""
+12 IF $DATA(DELTA(52.49,"EXTERNAL PROVIDER"))
Begin DoDot:1
+13 ; response message provider IEN
SET PROVIEN=$GET(PSODAT(F,PSOIENS,2.3,"I"))
+14 IF 'PROVIEN
SET PSOEXCNT=PSOEXCNT+1
SET PSOEXMS(PSOEXCNT)="Provider not linked. Cannot process renewal request."
QUIT
+15 ; if the provider or drug has been linked, then a change has occured in one of those segments, so they must be validated
+16 SET PRMVAL=$GET(PSODAT(F,PSOIENS,1.3,"I"))
IF 'PRMVAL
SET PSOEXCNT=PSOEXCNT+1
SET PSOEXMS(PSOEXCNT)="Provider not validated. Cannot process renewal request."
QUIT
End DoDot:1
+17 if $ORDER(PSOEXMS(0))
QUIT
+18 DO PSOHY(.PSOHY,PSOIEN,ORXIEN,RXIEN,PROVIEN)
QUIT
+19 QUIT
+20 ; ERXIEN - refill response IEN from 52.49
+21 ; ORXIEN - newRx IEN from 52.49
+22 ; RXIEN - prescription entry from file #52
+23 ; PROVOVR - provider override, when approved with changes included a change to the provider
PSOHY(PSOHY,ERXIEN,ORXIEN,RXIEN,PROVOVR) ;
+1 NEW RXDAT,ERXRFLS,ERXWDATE,LOC,ERXNUM,RXIENS,VAROUT,PROVIEN,EFFDT,VAOI,VADRUG,VAREF,PATIEN,VAPRIOR,ORDERTYP,VADAYS,VQTY
+2 NEW WRITDT,SLOOP,SCNT,SLOOP2
+3 SET RXIENS=RXIEN_","
+4 SET ERXNUM=$$GET1^DIQ(52.49,ERXIEN,.01,"E")
+5 DO GETS^DIQ(52,RXIEN,"**","IE","RXDAT")
+6 SET LOC=$GET(RXDAT(52,RXIENS,5,"I"))
+7 SET VAROUT=$GET(RXDAT(52,RXIENS,11,"I"))
+8 SET PROVIEN=$SELECT($GET(PROVOVR):PROVOVR,1:$GET(RXDAT(52,RXIENS,4,"I")))
+9 ; effective date CANNOT be null.. make sure it is set to something. written date is the first fall back, then todays date
+10 SET EFFDT=$$GET1^DIQ(52.49,ERXIEN,6.3,"I")
IF 'EFFDT
SET EFFDT=$$GET1^DIQ(52.49,ERXIEN,5.9,"I")
+11 IF 'EFFDT
SET EFFDT=DT
+12 SET VAOI=$GET(RXDAT(52,RXIENS,39.2,"I"))
+13 SET VQTY=$GET(RXDAT(52,RXIENS,7,"E"))
+14 SET VADRUG=$GET(RXDAT(52,RXIENS,6,"I"))
+15 ; always decrement 1 from # of refills, because refills is actually total # of fills.
+16 SET VAREF=$$GET1^DIQ(52.49,ERXIEN,5.6,"E")
+17 IF VAREF>0
SET VAREF=VAREF-1
+18 SET PATIEN=$GET(RXDAT(52,RXIENS,2,"I"))
+19 ; for now, set priority to routine
+20 SET VAPRIOR="R"
+21 SET VADAYS=$GET(RXDAT(52,RXIENS,8,"E"))
+22 SET WRITDT=$$GET1^DIQ(52.49,ERXIEN,5.9,"I")
+23 SET ORDERTYP="RNW"
+24 SET PSOHY("PREVORD")=RXIEN
+25 SET PSOHY("LOC")=LOC
SET PSOHY("CHNUM")=$GET(ERXNUM)
+26 SET PSOHY("PICK")=VAROUT
SET PSOHY("ENTER")=PROVIEN
+27 SET PSOHY("PROV")=PROVIEN
SET PSOHY("SDT")=EFFDT
+28 SET PSOHY("ITEM")=VAOI
SET PSOHY("DRUG")=VADRUG
+29 SET PSOHY("QTY")=VQTY
SET PSOHY("REF")=VAREF
+30 ; DFN cannot be newed/killed here because it needs to exist for the subsequent call.
+31 SET (PSOHY("PAT"),DFN)=PATIEN
SET PSOHY("OCC")=ORDERTYP
+32 ; Login date will always be the Message Received Date/Time
+33 SET PSOHY("EDT")=$$GET1^DIQ(52.49,ERXIEN,.03,"I")
SET PSOHY("PRIOR")=VAPRIOR
+34 ; ALWAYS PSO as the external application
+35 SET PSOHY("EXAPP")="PHARMACY"
+36 SET PSOHY("DAYS")=VADAYS
+37 QUIT
