PSOERXX1 ;ALB/BWF - eRx xml utilities ; 8/3/2016 5:14pm
;;7.0;OUTPATIENT PHARMACY;**467,520,527,508,581,617**;DEC 1997;Build 110
;
Q
; called by PSO ERX RX RENEWAL REQUEST action protocol
RREQLST(PSOLST,PSOSITE,PSOCNT) ;
N ITEM,SEL,ORD,I,ERXIEN,DONE,ORDER,ORDLST,RXIEN,RXDRUG,RXDRUGN,PRECHECK,DIR
D FULL^VALM1
S DIR("A")="Select Orders by number",DIR(0)="LO^1:"_PSOCNT D ^DIR I $D(DTOUT)!($D(DUOUT)) K DIR,DIRUT,DTOUT,DUOUT Q
S ORDLST=Y
W !!,"NOTE: If you have selected items that are not inbound eRx Prescriptions,"
W !,"those entries will be skipped during the RxRenewal process.",!!
K DIR
S DONE=0
F I=1:1 D Q:DONE
.S ITEM=$P(ORDLST,",",I) I ITEM="" S DONE=1 Q
.I $P(PSOLST(ITEM),U)'=52 W !,"This item is "_$P(PSOLST(ITEM),U,3)_" and cannot be renewed.",! D DIRE Q
.S RXIEN=$P(PSOLST(ITEM),U,2)
.S ORDER=$$GET1^DIQ(52,RXIEN,39.3,"I")
.S ERXIEN=$$CHKERX^PSOERXU1(ORDER) Q:'ERXIEN
.S RXDRUG=$$GET1^DIQ(52,RXIEN,6,"I"),RXDRUGN=$$GET1^DIQ(52,RXIEN,6,"E")
.W !!,"Now renewing prescription #: "_$$GET1^DIQ(52,RXIEN,.01,"E")
.W !,"Patient: "_$$GET1^DIQ(52,RXIEN,2,"E")
.W !,"Drug/Supply: "_RXDRUGN
.W !,"# of Refills: "_$$GET1^DIQ(52,RXIEN,9,"E"),?30,"Days Supply: "_$$GET1^DIQ(52,RXIEN,8,"E"),?52,"Quantity: "_$$GET1^DIQ(52,RXIEN,7,"E")
.S PRECHECK=$$RENEW^PSORENW(RXIEN,RXDRUG)
.I $P(PRECHECK,U)<1 W !,$P(PRECHECK,U,2),! D DIRE Q
.D RREQOP(ERXIEN,PSOSITE)
Q
; Called by PSO ERX SINGLE RX RENEWAL REQUEST action protocol
RREQSIN(RXIEN,PSOSITE) ;
N ORDER,ERXIEN,RXDRUG,RXDRUGN,PRECHECK
S ORDER=$$GET1^DIQ(52,RXIEN,39.3,"I") Q:'ORDER
S ERXIEN=$$CHKERX^PSOERXU1(ORDER) I 'ERXIEN W !!,"RxRenewal request may not be used. This prescription is not an eRx." D DIRE Q
S RXDRUG=$$GET1^DIQ(52,RXIEN,6,"I"),RXDRUGN=$$GET1^DIQ(52,RXIEN,6,"E")
W !!,"Now renewing prescription #: "_$$GET1^DIQ(52,RXIEN,.01,"E")
W !,"Patient: "_$$GET1^DIQ(52,RXIEN,2,"E")
W !,"Drug/Supply: "_RXDRUGN,!!
W !,"# of Refills: "_$$GET1^DIQ(52,RXIEN,9,"E"),?30,"Days Supply: "_$$GET1^DIQ(52,RXIEN,8,"E"),?52,"Quantity: "_$$GET1^DIQ(52,RXIEN,7,"E")
S PRECHECK=$$RENEW^PSORENW(RXIEN,RXDRUG)
I $P(PRECHECK,U)<1 W !,$P(PRECHECK,U,2),! Q
D RREQOP(ERXIEN,PSOSITE)
Q
; PSOIEN - ien from 52.49 (erx holding queue)
; PSOSITE - site ien from the outpatient site file (59)
; RX RENEWAL REQUEST VIA PSO LMOE FINISH/BACKDOOR ORDERS
RREQOP(PSOIEN,PSOSITE) ;
N ORNUM,RXIEN,PSSOUT,GBL,REFL,I,EXDT,PEND,PSSRET,CNT,DIR,Y,REFQTY,REFREQ,DIV,VADAT,RRCNT
N I,SSSTART,SSSTOP,GBL2,XXL1,XXL2,HUBID,NPIINST,STATION,Y,DIR,DONE,INNAME,NPI,NERXIEN,PROHIBIT1,PROHIBIT
N MSGIEN,MSGDT,RESIEN,SIG,SIGLEN,DTCUT,RTHID,PSORENW,EXPFLG,S2017,MTYPE,RESVAL,REQIEN
S VALMBCK="R"
Q:'PSOIEN!('PSOSITE)
S MTYPE=$$GET1^DIQ(52.49,PSOIEN,.08,"I")
I MTYPE="CX" S NERXIEN=$$FINDNRX^PSOERXU6(PSOIEN)
I MTYPE="CX" S PROHIBIT=$$GET1^DIQ(52.49,NERXIEN,301.3,"I")
I MTYPE'="CX" S PROHIBIT=$$GET1^DIQ(52.49,PSOIEN,301.3,"I")
I PROHIBIT W !!,"Renewals are prohibited for this eRx." D DIRE Q
S RESVAL=$$GET1^DIQ(52.49,PSOIEN,52.1,"I")
S S2017=$$GET1^DIQ(52.49,PSOIEN,312.1,"I")
S NPIINST=$$GET1^DIQ(59,PSOSITE,101,"I")
S INNAME=$$NAME^XUAF4(NPIINST)
S STATION=$$WHAT^XUAF4(NPIINST,99)
D FULL^VALM1
; bwf - if the NPI is not coming back from the $$NPI check, we have to pull it from the field
; iteself
S NPI=$$NPI^XUSNPI("Organization_ID",NPIINST) I $P(NPI,U)<1 D
.S NPI=$$WHAT^XUAF4(NPIINST,41.99)
I '$G(NPI) W !!,"NPI could not be established. Cannot create renewal request." D DIRE Q
S DIV=INNAME_U_NPI
S ORNUM=$$GET1^DIQ(52.49,PSOIEN,.12,"I") I 'ORNUM W !!,"No OE/RR order number. Cannot create renewal request." D DIRE Q
S PEND=$O(^PS(52.41,"B",ORNUM,0))
S RXIEN=$O(^PSRX("APL",ORNUM,0))
I PEND,'RXIEN W !!,"RX appears to be in Pending Outpatient Orders, but not yet processed to",!,"backdoor orders." D DIRE Q
I 'PEND,'RXIEN W !!,"Cannot resolve RX#. Please ensure the prescription is in the prescription file." D DIRE Q
I $$GET1^DIQ(52,RXIEN,100,"I")=5 W !!,"Rx is in suspense, cannot renew prescription." D DIRE Q
S PSORENW("ORX #")=$$GET1^DIQ(52,RXIEN,.01,"E")
I $A($E(PSORENW("ORX #"),$L(PSORENW("ORX #"))))'<90 W !!,"Cannot renew Rx # "_PSORENW("ORX #")_", Max number reached." D DIRE Q
S EXDT=$$GET1^DIQ(52,RXIEN,26,"I")
I EXDT<$$FMADD^XLFDT(DT,-120) W !!,"Medication has expired, cannot renew prescription." D DIRE Q
I EXDT<DT S EXPFLG=1
S REFL=$$GET1^DIQ(52,RXIEN,9,"I"),I=0 F S I=$O(^PSRX(RXIEN,1,I)) Q:'I S REFL=REFL-1
I REFL>0,'$G(EXPFLG) W !!,"Refills remaining for this prescription. Cannot create RxRenewal request." D DIRE Q
S (SIG,SIGLEN)=0 F S SIG=$O(^PSRX(RXIEN,"INS1",SIG)) Q:'SIG D
.S SIGLEN=$G(SIGLEN)+$L(^PSRX(RXIEN,"INS1",SIG,0))
I 'S2017,SIGLEN>140 W !!,"Sig is greater than 140 characters. Cannot create renewal request." D DIRE Q
S (DONE,RRCNT)=0,DTCUT=$$FMADD^XLFDT(DT,-30)
S REQIEN=$$GETREQ^PSOERXU2(PSOIEN)
S MSGIEN=999999999 F S MSGIEN=$O(^PS(52.49,PSOIEN,201,"B",MSGIEN),-1) Q:'MSGIEN D
.I $$GET1^DIQ(52.49,MSGIEN,.08,"I")'="RR" Q
.; if this is a renwal response/replace type, and the record is the related request, quit (dont show this one)
.I MTYPE="RE",RESVAL="R",MSGIEN=REQIEN,$$GET1^DIQ(52.49,REQIEN,.08,"I")="RR" Q
.S MSGDT=$$GET1^DIQ(52.49,MSGIEN,.03,"I")
.I MSGDT<DTCUT S DONE=1 Q
.S RRCNT=$G(RRCNT)+1
.S RESIEN=$$GETRESP^PSOERXU2(MSGIEN)
.W !!,"********************************************************************"
.W !!,"Previous RxRenewal Request Date/Time: "_$$FMTE^XLFDT(MSGDT)
.W !,"RxRenewal Requested by: "_$$GET1^DIQ(52.49,MSGIEN,51.1,"E")
.W !,"# of Refills Requested: "_$$GET1^DIQ(52.49,MSGIEN,51.2,"E")
.I 'RESIEN D Q
..W !!,"***No response received from provider.***",!
..S DIR(0)="E" D ^DIR K DIR
.W !!,"RxRenewal response Date/Time: "_$$GET1^DIQ(52.49,RESIEN,.03,"E")
.W !!,"RxRenewal response status: "_$$GET1^DIQ(52.49,RESIEN,1,"E")
.W !!,"********************************************************************"
I RRCNT>0 W !!,"Total Number of RxRenewal requests in the last 30 days: "_RRCNT,!!
I RRCNT D Q:'Y
.K DIR S DIR(0)="YO",DIR("B")="N",DIR("A")="Are you sure you would like to send ANOTHER RxRenewal request" D ^DIR
W !!,"Generating RxRenewal request for Rx #: "_$$GET1^DIQ(52,RXIEN,.01,"E"),!!
K DIR S DIR(0)="SO^R:RENEW WITH PRE-POPULATED VALUE;C:CHANGE # OF REFILLS;E:EXIT"
S DIR("?")=" E - Exit"
S DIR("?",1)=" R - Request the same # of refills as the original Rx"
S DIR("?",2)=" C - Request desired # of refills (0-11)"
D ^DIR K DIR
I Y="E"!$D(DIRUT)!(Y="^") Q
;Med Dispensed segments when the Qualifier is 'P' ('n' is the original Refill value sent on NEWRX)
S REFQTY=$$GET1^DIQ(52,RXIEN,9,"I")
I Y="R" D
.S REFREQ=REFQTY
;Refill with change Quantity (questions to be displayed to the user such as # of refills, Pharmacist Notes and so on)
S DONE=0
I Y="C" D
.F D Q:DONE!($G(REFREQ)'="")
..S DIR(0)="NO^0:11",DIR("A")="Enter # of Refills or '^' to exit" D ^DIR K DIR
..Q:Y=""
..I Y="^"!$D(DIRUT) S DONE=1 Q
..S REFREQ=Y
Q:DONE=1
S REFREQ=REFREQ+1
I '$G(REFREQ) W !!,"Number of Refills is required. RxRenewal request cancelled." S DIR(0)="E" D ^DIR K DIR
; display information to the user
W !!,"Sending RxRenewal request for:"
W !!,"Patient: "_$$GET1^DIQ(52,RXIEN,2,"E")
W !,"Patient Status: "_$$GET1^DIQ(52,RXIEN,3,"E")
W !,"Drug: "_$$GET1^DIQ(52,RXIEN,6,"E")
W !,"Orderable Item: "_$$GET1^DIQ(52,RXIEN,39.2,"E")
W !,"# of Refills Requested: "_REFREQ,?30,"Days Supply: "_$$GET1^DIQ(52,RXIEN,8,"E"),?52,"Quantity: "_$$GET1^DIQ(52,RXIEN,7,"E")
W !!,"Would you like to send this RxRenewal request to the prescriber"
S DIR(0)="YO",DIR("B")="N" D ^DIR K DIR
I Y<1!(Y=U) S DIR(0)="E" W !!,"RxRenewal Request cancelled! No RxRenewal request will be sent." D ^DIR K DIR Q
I 'S2017 S GBL=$$RREQ(PSOIEN,RXIEN,ORNUM,PSOSITE,.MESSID,REFREQ) I '$O(@GBL@(0)) W !!,"Could not create outgoing renewal message structure." D DIRE Q
I S2017 S GBL=$$RENEWREQ^PSOERXOA(PSOIEN,RXIEN,ORNUM,PSOSITE,.MESSID,REFREQ) I '$O(@GBL@(0)) W !!,"Could not create outgoing renewal message structure." D DIRE Q
S PSSRET=$$RESTPOST^PSOERXO1(.PSSRET,.GBL)
; if the post was unsuccessful, inform the user and quit.
I $P(PSSRET(0),U)<1 W !,$P(PSSRET(0),U,2) S DIR(0)="E" D ^DIR K DIR Q
I $D(PSSRET("errorMessage")) W !,PSSRET("errorMessage") S DIR(0)="E" D ^DIR K DIR Q
S HUBID=$G(PSSRET("outboundMsgId")) I 'HUBID W !,"The eRx Processing hub did not return a Hub identification number." S DIR(0)="E" D ^DIR K DIR Q
; vista generated message will be V12345 (V concatenated to the hubId)
S HUBID="V"_HUBID
W !!,"Renewal Request sent." S DIR(0)="E" D ^DIR K DIR
; Validates if the order is an eRx and Logs Activity in AL eRx for Approved Refill Response Pending Renewal Activity
D RXACT^PSOBPSU2(RXIEN,,"Electronic RxRenewal Request sent to External Provider","O")
N RES
I 'S2017 D
.S I=0 F S I=$O(@GBL@(I)) Q:'I!($G(SSSTART)) D
..I $G(@GBL@(I,0))="<StructuredSIG>" S SSSTART=I Q
.S I=999999999 F S I=$O(@GBL@(I),-1) Q:'I!$G(SSSTOP) D
..I $G(@GBL@(I,0))="</StructuredSIG>" S SSSTOP=I
.S GBL2=$NA(^TMP("STSIG^PSOERXX1",$J)) K @GBL2
.I $D(SSSTART),$D(SSSTOP) D
..F I=SSSTART:1:SSSTOP D
...S @GBL2@(I,0)=@GBL@(I,0) K @GBL@(I,0)
.; build streams
.; set BP
.S I=0 F S I=$O(@GBL@(I)) Q:'I D
..S XXL1=$G(XXL1)_$G(@GBL@(I,0))
.I $D(@GBL2) D
..S I=0 F S I=$O(@GBL2@(I)) Q:'I D
...S XXL2=$G(XXL2)_$G(@GBL2@(I,0))
..S XXL2="<SIG>"_XXL2_"</SIG>"
.I '$D(XXL2) S XXL2=""
.S VADAT=DUZ_U_RXIEN
.S RTHID=$$GET1^DIQ(52.49,PSOIEN,.01,"E")
.S HUBID=HUBID_U_U_RTHID
.D INCERX^PSOERXA1(.RES,.XXL1,"","","",STATION,DIV,HUBID,"",.XXL2,VADAT)
I S2017 D
.; build stream
.S I=0 F S I=$O(@GBL@(I)) Q:'I D
..S XXL1=$G(XXL1)_$G(@GBL@(I,0))
.S VADAT=DUZ_U_RXIEN
.S RTHID=$$GET1^DIQ(52.49,PSOIEN,.01,"E")
.S HUBID=HUBID_U_U_RTHID
.D INCERX^PSOERXI1(.RES,.XXL1,"","","",STATION,DIV,HUBID,"","",VADAT,"")
I $P(RES,U)=0 D
.W !,"A problem was encountered while trying to file the RxRenewal request."
.W !,"RxRenewal Request was not filed in vista."
.W !!,"ERROR: "_$P(RES,U,2)
.S DIR(0)="E" D ^DIR K DIR
K @GBL
Q
; CHANGE REQUEST VIA ERX HOLDING QUEUE
CREQHQ(PSOIEN,PSOSITE) ;
N ORNUM,RXIEN,DRUG,GBL,DROK,CNT,PSSRET
Q:'PSOIEN!('PSOSITE)
S ORNUM=$$GET1^DIQ(52.49,PSOIEN,.12,"I") ;I 'ORNUM W !!,"This order has been Accepted from eRx and cannot be changed." D DIRE Q
S RXIEN=$O(^PSRX("APL",ORNUM,0)) ;I 'RXIEN W !!,"A current prescription exists for this eRx. Cannot change eRx." D DIRE Q
; build drug information into array to be passed into xml builder
; for future use
; may consider having the user fill in the drug validation screen then issue change request. Or replicate
; drug validation section into another 'Change Request' screen.
S DROK=$$DRGPRMPT(.DRUG) I 'DROK W !!,"Insufficient drug information. Cannot create change request.",!,"Please try again." D DIRE Q
S GBL=$$CREQ(PSOIEN,.DRUG,PSOSITE,ORNUM,RXIEN) I '$L(GBL) W !!,"Could not create outgoing message structure." D DIRE Q
S PSSRET=$$RESTPOST^PSOERXO1(.PSSRET,.GBL)
; if the post was unsuccessful, inform the user and quit.
I $P(PSSRET(0),U)<1 W !,$P(PSSRET(0),U,2) S DIR(0)="E" D ^DIR K DIR Q
I $D(PSSRET("errorMessage")) W !,PSSRET("errorMessage") S DIR(0)="E" D ^DIR K DIR Q
W !!,"Change Request sent." S DIR(0)="E" D ^DIR K DIR
K @GBL
Q
; RXFILL MESSAGE
FMES(PSOIEN) ;
N ORNUM,RXIEN,DRUG,GBL,FTYPE,PSSRET,CNT
Q:'PSOIEN
S ORNUM=$$GET1^DIQ(52.49,PSOIEN,.12,"I") ;I 'ORNUM W !!,"No OE/RR order number. Cannot create rx renewal request." D DIRE Q
S RXIEN=$O(^PSRX("APL",ORNUM,0)) ;I 'RXIEN W !!,"Could not resolve RX #. Please contact technical support." D DIRE Q
S NOTE="TESTING NOTE"
S FTYPE="F"
S GBL=$$RXFILL(PSOIEN,FTYPE,NOTE,RXIEN,ORNUM) I '$L(GBL) W !!,"Could not create outgoing message structure." D DIRE Q
S PSSRET=$$RESTPOST^PSOERXO1(.PSSRET,.GBL)
; if the post was unsuccessful, inform the user and quit.
I $P(PSSRET(0),U)<1 W !,$P(PSSRET(0),U,2) S DIR(0)="E" D ^DIR K DIR Q
I $D(PSSRET("errorMessage")) W !,PSSRET("errorMessage") S DIR(0)="E" D ^DIR K DIR Q
W !!,"RxFill Message sent." S DIR(0)="E" D ^DIR K DIR
; if the message was successful, file the outbound message contents into 52.49
K @GBL
Q
; prompt for drug fields needed to create a change request - not currently used
DRGPRMPT(DRG) ;
; Prompt for drug
N DIC,PSODRUG,DIR,Y
S DIC(0)="AEMQ",DIC=50,DIC("S")="I $$ACTIVE^PSOERXA0(Y),($$OUTPAT^PSOERXA0(Y)),('$$INVCOMP^PSOERXA0(Y))" D ^DIC
K DIC
Q:$P(Y,U)<1 0
S DRG("DRUG")=$P(Y,U,2)
S PSODRUG("IEN")=$P(Y,U)
; prompt for days supply
K DIR S DIR(0)="52.49,20.2" D ^DIR
Q:$P(Y,U)<1 0
S DRG("DSUP")=Y
; prompt for quantity
K DIR S DIR(0)="52.49,20.1" D ^DIR
Q:$P(Y,U)<1 0
S DRG("QTY")=Y
; prompt for refills
K DIR S DIR(0)="52.49,20.5" D ^DIR
Q:$P(Y,U)<1 0
S DRG("REF")=Y
; prompt for directions
K DIR S DIR(0)="52.49,7" D ^DIR
Q:Y="^" 0
Q:Y']"" 0
S DRG("DIR")=Y
Q 1
; CHANGE REQUEST VIA BACKDOOR ORDERS
CREQBD(RXIEN) ;
Q
; CHANGE REQUEST VIA PSO LMOE FINISH
CREQPO(ORIEN) ;
Q
RREQ(PSOIEN,RXIEN,ORNUM,PSOSITE,MESSID,REFREQ) ;RefillRequest
N GBL,PSOIENS,CNT
Q:'PSOIEN ""
S GBL=$NA(^TMP("RREQ^PSOERXX1",$J)) K @GBL
S CNT=0
D MSG^PSOERXX2(.GBL,1)
; header
S MESSID=$$HDR^PSOERXX2(.GBL,PSOIEN)
; body header
D BHF^PSOERXX2(.GBL,1)
; request type header
D RTYPE^PSOERXX2(.GBL,"RefillRequest",1)
; request info - not currently used
;D REQUEST^PSOERXX2(.GBL,"ACC","ACC")
D VAPHARM^PSOERXX2(.GBL,PSOSITE,PSOIEN)
D PRESCRIB^PSOERXX2(.GBL,PSOSITE,PSOIEN)
D SUPERVIS^PSOERXX2(.GBL,PSOSITE,PSOIEN)
D FACIL^PSOERXX2(.GBL,PSOSITE,PSOIEN)
D PATIENT^PSOERXX3(.GBL,PSOSITE,PSOIEN)
D MEDPRES^PSOERXX4(.GBL,PSOIEN,REFREQ,REFREQ)
D MEDDIS^PSOERXX4(.GBL,RXIEN,ORNUM,PSOIEN,REFREQ)
D OBSERVE^PSOERXX3(.GBL,PSOIEN)
D BENEFITS^PSOERXX3(.GBL,PSOIEN)
D DRUGEVAL^PSOERXX3(.GBL,PSOIEN)
;D DIAGNOS(.GBL,PSOIEN)
D RTYPE^PSOERXX2(.GBL,"RefillRequest",2)
D BHF^PSOERXX2(.GBL,2)
D MSG^PSOERXX2(.GBL,2)
Q GBL
; PSOIEN - erx IEN from 52.49
CREQ(PSOIEN,REQDRUG,PSOSITE,ORNUM,RXIEN) ;ChangeRequest
N GBL,PSOIENS,CNT
Q:'PSOIEN ""
S GBL=$NA(^TMP("CREQ^PSOERXX1",$J)) K @GBL
S CNT=0
D MSG^PSOERXX2(.GBL,1)
; header
D HDR^PSOERXX2(.GBL,PSOIEN)
; body header
D BHF^PSOERXX2(.GBL,1)
; request type header
D RTYPE^PSOERXX2(.GBL,"RxChangeRequest",1)
; request info
D REQUEST^PSOERXX2(.GBL,"TST","TST")
D VAPHARM^PSOERXX2(.GBL,PSOSITE,PSOIEN)
D PRESCRIB^PSOERXX2(.GBL,PSOIEN)
D SUPERVIS^PSOERXX2(.GBL,PSOIEN)
D FACIL^PSOERXX2(.GBL,PSOIEN)
D PATIENT^PSOERXX3(.GBL,PSOIEN)
D MEDPRES^PSOERXX4(.GBL,PSOIEN)
D MEDREQ^PSOERXX4(.GBL,PSOIEN,.REQDRUG)
D OBSERVE^PSOERXX3(.GBL,PSOIEN)
D BENEFITS^PSOERXX3(.GBL,PSOIEN)
D DRUGEVAL^PSOERXX3(.GBL,PSOIEN)
D DIAGNOS^PSOERXX3(.GBL,PSOIEN)
D RTYPE^PSOERXX2(.GBL,"RxChangeRequest",2)
D BHF^PSOERXX2(.GBL,2)
D MSG^PSOERXX2(.GBL,2)
Q GBL
; FP - full or partial fill (F/P)
; NOTE - fill notes
RXFILL(PSOIEN,FP,NOTE,RXIEN,ORNUM) ;
N GBL,PSOIENS,CNT
Q:'PSOIEN ""
S GBL=$NA(^TMP("RXFILL^PSOERXX1",$J)) K @GBL
S CNT=0
D MSG^PSOERXX2(.GBL,1)
; header
D HDR^PSOERXX2(.GBL,PSOIEN)
; body header
D BHF^PSOERXX2(.GBL,1)
; request type header
D RTYPE^PSOERXX2(.GBL,"RxFill",1)
; request info
S FP="F"
S NOTE=$G(NOTE,"TESTING NOTES")
; fill status
D FILLST^PSOERXX3(.GBL,FP,NOTE)
D VAPHARM^PSOERXX2(.GBL,PSOIEN)
D PRESCRIB^PSOERXX2(.GBL,PSOIEN)
D SUPERVIS^PSOERXX2(.GBL,PSOIEN)
D FACIL^PSOERXX2(.GBL,PSOIEN)
D PATIENT^PSOERXX3(.GBL,PSOIEN)
D MEDPRES^PSOERXX4(.GBL,PSOIEN)
D MEDDIS^PSOERXX4(.GBL,PSOIEN)
D OBSERVE^PSOERXX3(.GBL,PSOIEN)
D BENEFITS^PSOERXX3(.GBL,PSOIEN)
D DRUGEVAL^PSOERXX3(.GBL,PSOIEN)
;D DIAGNOS^PSOERXX3(.GBL,PSOIEN)
D RTYPE^PSOERXX2(.GBL,"RxFill",2)
D BHF^PSOERXX2(.GBL,2)
D MSG^PSOERXX2(.GBL,2)
Q GBL
DIRE ;
N DIR S DIR(0)="E" D ^DIR
Q
CONVXML(ARYNM) ;
N F,F2,F3,F4,DATA
S F=0 F S F=$O(@ARYNM@(F)) Q:F="" D
.S F2="" F S F2=$O(@ARYNM@(F,F2)) Q:F2="" D
..S F3="" F S F3=$O(@ARYNM@(F,F2,F3)) Q:F3="" D
...S F4="" F S F4=$O(@ARYNM@(F,F2,F3,F4)) Q:F4="" D
....S DATA=$G(@ARYNM@(F,F2,F3,F4))
....S DATA=$$SYMENC^MXMLUTL(DATA)
....S @ARYNM@(F,F2,F3,F4)=DATA
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOERXX1 16395 printed Sep 23, 2025@20:05:37 Page 2
PSOERXX1 ;ALB/BWF - eRx xml utilities ; 8/3/2016 5:14pm
+1 ;;7.0;OUTPATIENT PHARMACY;**467,520,527,508,581,617**;DEC 1997;Build 110
+2 ;
+3 QUIT
+4 ; called by PSO ERX RX RENEWAL REQUEST action protocol
RREQLST(PSOLST,PSOSITE,PSOCNT) ;
+1 NEW ITEM,SEL,ORD,I,ERXIEN,DONE,ORDER,ORDLST,RXIEN,RXDRUG,RXDRUGN,PRECHECK,DIR
+2 DO FULL^VALM1
+3 SET DIR("A")="Select Orders by number"
SET DIR(0)="LO^1:"_PSOCNT
DO ^DIR
IF $DATA(DTOUT)!($DATA(DUOUT))
KILL DIR,DIRUT,DTOUT,DUOUT
QUIT
+4 SET ORDLST=Y
+5 WRITE !!,"NOTE: If you have selected items that are not inbound eRx Prescriptions,"
+6 WRITE !,"those entries will be skipped during the RxRenewal process.",!!
+7 KILL DIR
+8 SET DONE=0
+9 FOR I=1:1
Begin DoDot:1
+10 SET ITEM=$PIECE(ORDLST,",",I)
IF ITEM=""
SET DONE=1
QUIT
+11 IF $PIECE(PSOLST(ITEM),U)'=52
WRITE !,"This item is "_$PIECE(PSOLST(ITEM),U,3)_" and cannot be renewed.",!
DO DIRE
QUIT
+12 SET RXIEN=$PIECE(PSOLST(ITEM),U,2)
+13 SET ORDER=$$GET1^DIQ(52,RXIEN,39.3,"I")
+14 SET ERXIEN=$$CHKERX^PSOERXU1(ORDER)
if 'ERXIEN
QUIT
+15 SET RXDRUG=$$GET1^DIQ(52,RXIEN,6,"I")
SET RXDRUGN=$$GET1^DIQ(52,RXIEN,6,"E")
+16 WRITE !!,"Now renewing prescription #: "_$$GET1^DIQ(52,RXIEN,.01,"E")
+17 WRITE !,"Patient: "_$$GET1^DIQ(52,RXIEN,2,"E")
+18 WRITE !,"Drug/Supply: "_RXDRUGN
+19 WRITE !,"# of Refills: "_$$GET1^DIQ(52,RXIEN,9,"E"),?30,"Days Supply: "_$$GET1^DIQ(52,RXIEN,8,"E"),?52,"Quantity: "_$$GET1^DIQ(52,RXIEN,7,"E")
+20 SET PRECHECK=$$RENEW^PSORENW(RXIEN,RXDRUG)
+21 IF $PIECE(PRECHECK,U)<1
WRITE !,$PIECE(PRECHECK,U,2),!
DO DIRE
QUIT
+22 DO RREQOP(ERXIEN,PSOSITE)
End DoDot:1
if DONE
QUIT
+23 QUIT
+24 ; Called by PSO ERX SINGLE RX RENEWAL REQUEST action protocol
RREQSIN(RXIEN,PSOSITE) ;
+1 NEW ORDER,ERXIEN,RXDRUG,RXDRUGN,PRECHECK
+2 SET ORDER=$$GET1^DIQ(52,RXIEN,39.3,"I")
if 'ORDER
QUIT
+3 SET ERXIEN=$$CHKERX^PSOERXU1(ORDER)
IF 'ERXIEN
WRITE !!,"RxRenewal request may not be used. This prescription is not an eRx."
DO DIRE
QUIT
+4 SET RXDRUG=$$GET1^DIQ(52,RXIEN,6,"I")
SET RXDRUGN=$$GET1^DIQ(52,RXIEN,6,"E")
+5 WRITE !!,"Now renewing prescription #: "_$$GET1^DIQ(52,RXIEN,.01,"E")
+6 WRITE !,"Patient: "_$$GET1^DIQ(52,RXIEN,2,"E")
+7 WRITE !,"Drug/Supply: "_RXDRUGN,!!
+8 WRITE !,"# of Refills: "_$$GET1^DIQ(52,RXIEN,9,"E"),?30,"Days Supply: "_$$GET1^DIQ(52,RXIEN,8,"E"),?52,"Quantity: "_$$GET1^DIQ(52,RXIEN,7,"E")
+9 SET PRECHECK=$$RENEW^PSORENW(RXIEN,RXDRUG)
+10 IF $PIECE(PRECHECK,U)<1
WRITE !,$PIECE(PRECHECK,U,2),!
QUIT
+11 DO RREQOP(ERXIEN,PSOSITE)
+12 QUIT
+13 ; PSOIEN - ien from 52.49 (erx holding queue)
+14 ; PSOSITE - site ien from the outpatient site file (59)
+15 ; RX RENEWAL REQUEST VIA PSO LMOE FINISH/BACKDOOR ORDERS
RREQOP(PSOIEN,PSOSITE) ;
+1 NEW ORNUM,RXIEN,PSSOUT,GBL,REFL,I,EXDT,PEND,PSSRET,CNT,DIR,Y,REFQTY,REFREQ,DIV,VADAT,RRCNT
+2 NEW I,SSSTART,SSSTOP,GBL2,XXL1,XXL2,HUBID,NPIINST,STATION,Y,DIR,DONE,INNAME,NPI,NERXIEN,PROHIBIT1,PROHIBIT
+3 NEW MSGIEN,MSGDT,RESIEN,SIG,SIGLEN,DTCUT,RTHID,PSORENW,EXPFLG,S2017,MTYPE,RESVAL,REQIEN
+4 SET VALMBCK="R"
+5 if 'PSOIEN!('PSOSITE)
QUIT
+6 SET MTYPE=$$GET1^DIQ(52.49,PSOIEN,.08,"I")
+7 IF MTYPE="CX"
SET NERXIEN=$$FINDNRX^PSOERXU6(PSOIEN)
+8 IF MTYPE="CX"
SET PROHIBIT=$$GET1^DIQ(52.49,NERXIEN,301.3,"I")
+9 IF MTYPE'="CX"
SET PROHIBIT=$$GET1^DIQ(52.49,PSOIEN,301.3,"I")
+10 IF PROHIBIT
WRITE !!,"Renewals are prohibited for this eRx."
DO DIRE
QUIT
+11 SET RESVAL=$$GET1^DIQ(52.49,PSOIEN,52.1,"I")
+12 SET S2017=$$GET1^DIQ(52.49,PSOIEN,312.1,"I")
+13 SET NPIINST=$$GET1^DIQ(59,PSOSITE,101,"I")
+14 SET INNAME=$$NAME^XUAF4(NPIINST)
+15 SET STATION=$$WHAT^XUAF4(NPIINST,99)
+16 DO FULL^VALM1
+17 ; bwf - if the NPI is not coming back from the $$NPI check, we have to pull it from the field
+18 ; iteself
+19 SET NPI=$$NPI^XUSNPI("Organization_ID",NPIINST)
IF $PIECE(NPI,U)<1
Begin DoDot:1
+20 SET NPI=$$WHAT^XUAF4(NPIINST,41.99)
End DoDot:1
+21 IF '$GET(NPI)
WRITE !!,"NPI could not be established. Cannot create renewal request."
DO DIRE
QUIT
+22 SET DIV=INNAME_U_NPI
+23 SET ORNUM=$$GET1^DIQ(52.49,PSOIEN,.12,"I")
IF 'ORNUM
WRITE !!,"No OE/RR order number. Cannot create renewal request."
DO DIRE
QUIT
+24 SET PEND=$ORDER(^PS(52.41,"B",ORNUM,0))
+25 SET RXIEN=$ORDER(^PSRX("APL",ORNUM,0))
+26 IF PEND
IF 'RXIEN
WRITE !!,"RX appears to be in Pending Outpatient Orders, but not yet processed to",!,"backdoor orders."
DO DIRE
QUIT
+27 IF 'PEND
IF 'RXIEN
WRITE !!,"Cannot resolve RX#. Please ensure the prescription is in the prescription file."
DO DIRE
QUIT
+28 IF $$GET1^DIQ(52,RXIEN,100,"I")=5
WRITE !!,"Rx is in suspense, cannot renew prescription."
DO DIRE
QUIT
+29 SET PSORENW("ORX #")=$$GET1^DIQ(52,RXIEN,.01,"E")
+30 IF $ASCII($EXTRACT(PSORENW("ORX #"),$LENGTH(PSORENW("ORX #"))))'<90
WRITE !!,"Cannot renew Rx # "_PSORENW("ORX #")_", Max number reached."
DO DIRE
QUIT
+31 SET EXDT=$$GET1^DIQ(52,RXIEN,26,"I")
+32 IF EXDT<$$FMADD^XLFDT(DT,-120)
WRITE !!,"Medication has expired, cannot renew prescription."
DO DIRE
QUIT
+33 IF EXDT<DT
SET EXPFLG=1
+34 SET REFL=$$GET1^DIQ(52,RXIEN,9,"I")
SET I=0
FOR
SET I=$ORDER(^PSRX(RXIEN,1,I))
if 'I
QUIT
SET REFL=REFL-1
+35 IF REFL>0
IF '$GET(EXPFLG)
WRITE !!,"Refills remaining for this prescription. Cannot create RxRenewal request."
DO DIRE
QUIT
+36 SET (SIG,SIGLEN)=0
FOR
SET SIG=$ORDER(^PSRX(RXIEN,"INS1",SIG))
if 'SIG
QUIT
Begin DoDot:1
+37 SET SIGLEN=$GET(SIGLEN)+$LENGTH(^PSRX(RXIEN,"INS1",SIG,0))
End DoDot:1
+38 IF 'S2017
IF SIGLEN>140
WRITE !!,"Sig is greater than 140 characters. Cannot create renewal request."
DO DIRE
QUIT
+39 SET (DONE,RRCNT)=0
SET DTCUT=$$FMADD^XLFDT(DT,-30)
+40 SET REQIEN=$$GETREQ^PSOERXU2(PSOIEN)
+41 SET MSGIEN=999999999
FOR
SET MSGIEN=$ORDER(^PS(52.49,PSOIEN,201,"B",MSGIEN),-1)
if 'MSGIEN
QUIT
Begin DoDot:1
+42 IF $$GET1^DIQ(52.49,MSGIEN,.08,"I")'="RR"
QUIT
+43 ; if this is a renwal response/replace type, and the record is the related request, quit (dont show this one)
+44 IF MTYPE="RE"
IF RESVAL="R"
IF MSGIEN=REQIEN
IF $$GET1^DIQ(52.49,REQIEN,.08,"I")="RR"
QUIT
+45 SET MSGDT=$$GET1^DIQ(52.49,MSGIEN,.03,"I")
+46 IF MSGDT<DTCUT
SET DONE=1
QUIT
+47 SET RRCNT=$GET(RRCNT)+1
+48 SET RESIEN=$$GETRESP^PSOERXU2(MSGIEN)
+49 WRITE !!,"********************************************************************"
+50 WRITE !!,"Previous RxRenewal Request Date/Time: "_$$FMTE^XLFDT(MSGDT)
+51 WRITE !,"RxRenewal Requested by: "_$$GET1^DIQ(52.49,MSGIEN,51.1,"E")
+52 WRITE !,"# of Refills Requested: "_$$GET1^DIQ(52.49,MSGIEN,51.2,"E")
+53 IF 'RESIEN
Begin DoDot:2
+54 WRITE !!,"***No response received from provider.***",!
+55 SET DIR(0)="E"
DO ^DIR
KILL DIR
End DoDot:2
QUIT
+56 WRITE !!,"RxRenewal response Date/Time: "_$$GET1^DIQ(52.49,RESIEN,.03,"E")
+57 WRITE !!,"RxRenewal response status: "_$$GET1^DIQ(52.49,RESIEN,1,"E")
+58 WRITE !!,"********************************************************************"
End DoDot:1
+59 IF RRCNT>0
WRITE !!,"Total Number of RxRenewal requests in the last 30 days: "_RRCNT,!!
+60 IF RRCNT
Begin DoDot:1
+61 KILL DIR
SET DIR(0)="YO"
SET DIR("B")="N"
SET DIR("A")="Are you sure you would like to send ANOTHER RxRenewal request"
DO ^DIR
End DoDot:1
if 'Y
QUIT
+62 WRITE !!,"Generating RxRenewal request for Rx #: "_$$GET1^DIQ(52,RXIEN,.01,"E"),!!
+63 KILL DIR
SET DIR(0)="SO^R:RENEW WITH PRE-POPULATED VALUE;C:CHANGE # OF REFILLS;E:EXIT"
+64 SET DIR("?")=" E - Exit"
+65 SET DIR("?",1)=" R - Request the same # of refills as the original Rx"
+66 SET DIR("?",2)=" C - Request desired # of refills (0-11)"
+67 DO ^DIR
KILL DIR
+68 IF Y="E"!$DATA(DIRUT)!(Y="^")
QUIT
+69 ;Med Dispensed segments when the Qualifier is 'P' ('n' is the original Refill value sent on NEWRX)
+70 SET REFQTY=$$GET1^DIQ(52,RXIEN,9,"I")
+71 IF Y="R"
Begin DoDot:1
+72 SET REFREQ=REFQTY
End DoDot:1
+73 ;Refill with change Quantity (questions to be displayed to the user such as # of refills, Pharmacist Notes and so on)
+74 SET DONE=0
+75 IF Y="C"
Begin DoDot:1
+76 FOR
Begin DoDot:2
+77 SET DIR(0)="NO^0:11"
SET DIR("A")="Enter # of Refills or '^' to exit"
DO ^DIR
KILL DIR
+78 if Y=""
QUIT
+79 IF Y="^"!$DATA(DIRUT)
SET DONE=1
QUIT
+80 SET REFREQ=Y
End DoDot:2
if DONE!($GET(REFREQ)'="")
QUIT
End DoDot:1
+81 if DONE=1
QUIT
+82 SET REFREQ=REFREQ+1
+83 IF '$GET(REFREQ)
WRITE !!,"Number of Refills is required. RxRenewal request cancelled."
SET DIR(0)="E"
DO ^DIR
KILL DIR
+84 ; display information to the user
+85 WRITE !!,"Sending RxRenewal request for:"
+86 WRITE !!,"Patient: "_$$GET1^DIQ(52,RXIEN,2,"E")
+87 WRITE !,"Patient Status: "_$$GET1^DIQ(52,RXIEN,3,"E")
+88 WRITE !,"Drug: "_$$GET1^DIQ(52,RXIEN,6,"E")
+89 WRITE !,"Orderable Item: "_$$GET1^DIQ(52,RXIEN,39.2,"E")
+90 WRITE !,"# of Refills Requested: "_REFREQ,?30,"Days Supply: "_$$GET1^DIQ(52,RXIEN,8,"E"),?52,"Quantity: "_$$GET1^DIQ(52,RXIEN,7,"E")
+91 WRITE !!,"Would you like to send this RxRenewal request to the prescriber"
+92 SET DIR(0)="YO"
SET DIR("B")="N"
DO ^DIR
KILL DIR
+93 IF Y<1!(Y=U)
SET DIR(0)="E"
WRITE !!,"RxRenewal Request cancelled! No RxRenewal request will be sent."
DO ^DIR
KILL DIR
QUIT
+94 IF 'S2017
SET GBL=$$RREQ(PSOIEN,RXIEN,ORNUM,PSOSITE,.MESSID,REFREQ)
IF '$ORDER(@GBL@(0))
WRITE !!,"Could not create outgoing renewal message structure."
DO DIRE
QUIT
+95 IF S2017
SET GBL=$$RENEWREQ^PSOERXOA(PSOIEN,RXIEN,ORNUM,PSOSITE,.MESSID,REFREQ)
IF '$ORDER(@GBL@(0))
WRITE !!,"Could not create outgoing renewal message structure."
DO DIRE
QUIT
+96 SET PSSRET=$$RESTPOST^PSOERXO1(.PSSRET,.GBL)
+97 ; if the post was unsuccessful, inform the user and quit.
+98 IF $PIECE(PSSRET(0),U)<1
WRITE !,$PIECE(PSSRET(0),U,2)
SET DIR(0)="E"
DO ^DIR
KILL DIR
QUIT
+99 IF $DATA(PSSRET("errorMessage"))
WRITE !,PSSRET("errorMessage")
SET DIR(0)="E"
DO ^DIR
KILL DIR
QUIT
+100 SET HUBID=$GET(PSSRET("outboundMsgId"))
IF 'HUBID
WRITE !,"The eRx Processing hub did not return a Hub identification number."
SET DIR(0)="E"
DO ^DIR
KILL DIR
QUIT
+101 ; vista generated message will be V12345 (V concatenated to the hubId)
+102 SET HUBID="V"_HUBID
+103 WRITE !!,"Renewal Request sent."
SET DIR(0)="E"
DO ^DIR
KILL DIR
+104 ; Validates if the order is an eRx and Logs Activity in AL eRx for Approved Refill Response Pending Renewal Activity
+105 DO RXACT^PSOBPSU2(RXIEN,,"Electronic RxRenewal Request sent to External Provider","O")
+106 NEW RES
+107 IF 'S2017
Begin DoDot:1
+108 SET I=0
FOR
SET I=$ORDER(@GBL@(I))
if 'I!($GET(SSSTART))
QUIT
Begin DoDot:2
+109 IF $GET(@GBL@(I,0))="<StructuredSIG>"
SET SSSTART=I
QUIT
End DoDot:2
+110 SET I=999999999
FOR
SET I=$ORDER(@GBL@(I),-1)
if 'I!$GET(SSSTOP)
QUIT
Begin DoDot:2
+111 IF $GET(@GBL@(I,0))="</StructuredSIG>"
SET SSSTOP=I
End DoDot:2
+112 SET GBL2=$NAME(^TMP("STSIG^PSOERXX1",$JOB))
KILL @GBL2
+113 IF $DATA(SSSTART)
IF $DATA(SSSTOP)
Begin DoDot:2
+114 FOR I=SSSTART:1:SSSTOP
Begin DoDot:3
+115 SET @GBL2@(I,0)=@GBL@(I,0)
KILL @GBL@(I,0)
End DoDot:3
End DoDot:2
+116 ; build streams
+117 ; set BP
+118 SET I=0
FOR
SET I=$ORDER(@GBL@(I))
if 'I
QUIT
Begin DoDot:2
+119 SET XXL1=$GET(XXL1)_$GET(@GBL@(I,0))
End DoDot:2
+120 IF $DATA(@GBL2)
Begin DoDot:2
+121 SET I=0
FOR
SET I=$ORDER(@GBL2@(I))
if 'I
QUIT
Begin DoDot:3
+122 SET XXL2=$GET(XXL2)_$GET(@GBL2@(I,0))
End DoDot:3
+123 SET XXL2="<SIG>"_XXL2_"</SIG>"
End DoDot:2
+124 IF '$DATA(XXL2)
SET XXL2=""
+125 SET VADAT=DUZ_U_RXIEN
+126 SET RTHID=$$GET1^DIQ(52.49,PSOIEN,.01,"E")
+127 SET HUBID=HUBID_U_U_RTHID
+128 DO INCERX^PSOERXA1(.RES,.XXL1,"","","",STATION,DIV,HUBID,"",.XXL2,VADAT)
End DoDot:1
+129 IF S2017
Begin DoDot:1
+130 ; build stream
+131 SET I=0
FOR
SET I=$ORDER(@GBL@(I))
if 'I
QUIT
Begin DoDot:2
+132 SET XXL1=$GET(XXL1)_$GET(@GBL@(I,0))
End DoDot:2
+133 SET VADAT=DUZ_U_RXIEN
+134 SET RTHID=$$GET1^DIQ(52.49,PSOIEN,.01,"E")
+135 SET HUBID=HUBID_U_U_RTHID
+136 DO INCERX^PSOERXI1(.RES,.XXL1,"","","",STATION,DIV,HUBID,"","",VADAT,"")
End DoDot:1
+137 IF $PIECE(RES,U)=0
Begin DoDot:1
+138 WRITE !,"A problem was encountered while trying to file the RxRenewal request."
+139 WRITE !,"RxRenewal Request was not filed in vista."
+140 WRITE !!,"ERROR: "_$PIECE(RES,U,2)
+141 SET DIR(0)="E"
DO ^DIR
KILL DIR
End DoDot:1
+142 KILL @GBL
+143 QUIT
+144 ; CHANGE REQUEST VIA ERX HOLDING QUEUE
CREQHQ(PSOIEN,PSOSITE) ;
+1 NEW ORNUM,RXIEN,DRUG,GBL,DROK,CNT,PSSRET
+2 if 'PSOIEN!('PSOSITE)
QUIT
+3 ;I 'ORNUM W !!,"This order has been Accepted from eRx and cannot be changed." D DIRE Q
SET ORNUM=$$GET1^DIQ(52.49,PSOIEN,.12,"I")
+4 ;I 'RXIEN W !!,"A current prescription exists for this eRx. Cannot change eRx." D DIRE Q
SET RXIEN=$ORDER(^PSRX("APL",ORNUM,0))
+5 ; build drug information into array to be passed into xml builder
+6 ; for future use
+7 ; may consider having the user fill in the drug validation screen then issue change request. Or replicate
+8 ; drug validation section into another 'Change Request' screen.
+9 SET DROK=$$DRGPRMPT(.DRUG)
IF 'DROK
WRITE !!,"Insufficient drug information. Cannot create change request.",!,"Please try again."
DO DIRE
QUIT
+10 SET GBL=$$CREQ(PSOIEN,.DRUG,PSOSITE,ORNUM,RXIEN)
IF '$LENGTH(GBL)
WRITE !!,"Could not create outgoing message structure."
DO DIRE
QUIT
+11 SET PSSRET=$$RESTPOST^PSOERXO1(.PSSRET,.GBL)
+12 ; if the post was unsuccessful, inform the user and quit.
+13 IF $PIECE(PSSRET(0),U)<1
WRITE !,$PIECE(PSSRET(0),U,2)
SET DIR(0)="E"
DO ^DIR
KILL DIR
QUIT
+14 IF $DATA(PSSRET("errorMessage"))
WRITE !,PSSRET("errorMessage")
SET DIR(0)="E"
DO ^DIR
KILL DIR
QUIT
+15 WRITE !!,"Change Request sent."
SET DIR(0)="E"
DO ^DIR
KILL DIR
+16 KILL @GBL
+17 QUIT
+18 ; RXFILL MESSAGE
FMES(PSOIEN) ;
+1 NEW ORNUM,RXIEN,DRUG,GBL,FTYPE,PSSRET,CNT
+2 if 'PSOIEN
QUIT
+3 ;I 'ORNUM W !!,"No OE/RR order number. Cannot create rx renewal request." D DIRE Q
SET ORNUM=$$GET1^DIQ(52.49,PSOIEN,.12,"I")
+4 ;I 'RXIEN W !!,"Could not resolve RX #. Please contact technical support." D DIRE Q
SET RXIEN=$ORDER(^PSRX("APL",ORNUM,0))
+5 SET NOTE="TESTING NOTE"
+6 SET FTYPE="F"
+7 SET GBL=$$RXFILL(PSOIEN,FTYPE,NOTE,RXIEN,ORNUM)
IF '$LENGTH(GBL)
WRITE !!,"Could not create outgoing message structure."
DO DIRE
QUIT
+8 SET PSSRET=$$RESTPOST^PSOERXO1(.PSSRET,.GBL)
+9 ; if the post was unsuccessful, inform the user and quit.
+10 IF $PIECE(PSSRET(0),U)<1
WRITE !,$PIECE(PSSRET(0),U,2)
SET DIR(0)="E"
DO ^DIR
KILL DIR
QUIT
+11 IF $DATA(PSSRET("errorMessage"))
WRITE !,PSSRET("errorMessage")
SET DIR(0)="E"
DO ^DIR
KILL DIR
QUIT
+12 WRITE !!,"RxFill Message sent."
SET DIR(0)="E"
DO ^DIR
KILL DIR
+13 ; if the message was successful, file the outbound message contents into 52.49
+14 KILL @GBL
+15 QUIT
+16 ; prompt for drug fields needed to create a change request - not currently used
DRGPRMPT(DRG) ;
+1 ; Prompt for drug
+2 NEW DIC,PSODRUG,DIR,Y
+3 SET DIC(0)="AEMQ"
SET DIC=50
SET DIC("S")="I $$ACTIVE^PSOERXA0(Y),($$OUTPAT^PSOERXA0(Y)),('$$INVCOMP^PSOERXA0(Y))"
DO ^DIC
+4 KILL DIC
+5 if $PIECE(Y,U)<1
QUIT 0
+6 SET DRG("DRUG")=$PIECE(Y,U,2)
+7 SET PSODRUG("IEN")=$PIECE(Y,U)
+8 ; prompt for days supply
+9 KILL DIR
SET DIR(0)="52.49,20.2"
DO ^DIR
+10 if $PIECE(Y,U)<1
QUIT 0
+11 SET DRG("DSUP")=Y
+12 ; prompt for quantity
+13 KILL DIR
SET DIR(0)="52.49,20.1"
DO ^DIR
+14 if $PIECE(Y,U)<1
QUIT 0
+15 SET DRG("QTY")=Y
+16 ; prompt for refills
+17 KILL DIR
SET DIR(0)="52.49,20.5"
DO ^DIR
+18 if $PIECE(Y,U)<1
QUIT 0
+19 SET DRG("REF")=Y
+20 ; prompt for directions
+21 KILL DIR
SET DIR(0)="52.49,7"
DO ^DIR
+22 if Y="^"
QUIT 0
+23 if Y']""
QUIT 0
+24 SET DRG("DIR")=Y
+25 QUIT 1
+26 ; CHANGE REQUEST VIA BACKDOOR ORDERS
CREQBD(RXIEN) ;
+1 QUIT
+2 ; CHANGE REQUEST VIA PSO LMOE FINISH
CREQPO(ORIEN) ;
+1 QUIT
RREQ(PSOIEN,RXIEN,ORNUM,PSOSITE,MESSID,REFREQ) ;RefillRequest
+1 NEW GBL,PSOIENS,CNT
+2 if 'PSOIEN
QUIT ""
+3 SET GBL=$NAME(^TMP("RREQ^PSOERXX1",$JOB))
KILL @GBL
+4 SET CNT=0
+5 DO MSG^PSOERXX2(.GBL,1)
+6 ; header
+7 SET MESSID=$$HDR^PSOERXX2(.GBL,PSOIEN)
+8 ; body header
+9 DO BHF^PSOERXX2(.GBL,1)
+10 ; request type header
+11 DO RTYPE^PSOERXX2(.GBL,"RefillRequest",1)
+12 ; request info - not currently used
+13 ;D REQUEST^PSOERXX2(.GBL,"ACC","ACC")
+14 DO VAPHARM^PSOERXX2(.GBL,PSOSITE,PSOIEN)
+15 DO PRESCRIB^PSOERXX2(.GBL,PSOSITE,PSOIEN)
+16 DO SUPERVIS^PSOERXX2(.GBL,PSOSITE,PSOIEN)
+17 DO FACIL^PSOERXX2(.GBL,PSOSITE,PSOIEN)
+18 DO PATIENT^PSOERXX3(.GBL,PSOSITE,PSOIEN)
+19 DO MEDPRES^PSOERXX4(.GBL,PSOIEN,REFREQ,REFREQ)
+20 DO MEDDIS^PSOERXX4(.GBL,RXIEN,ORNUM,PSOIEN,REFREQ)
+21 DO OBSERVE^PSOERXX3(.GBL,PSOIEN)
+22 DO BENEFITS^PSOERXX3(.GBL,PSOIEN)
+23 DO DRUGEVAL^PSOERXX3(.GBL,PSOIEN)
+24 ;D DIAGNOS(.GBL,PSOIEN)
+25 DO RTYPE^PSOERXX2(.GBL,"RefillRequest",2)
+26 DO BHF^PSOERXX2(.GBL,2)
+27 DO MSG^PSOERXX2(.GBL,2)
+28 QUIT GBL
+29 ; PSOIEN - erx IEN from 52.49
CREQ(PSOIEN,REQDRUG,PSOSITE,ORNUM,RXIEN) ;ChangeRequest
+1 NEW GBL,PSOIENS,CNT
+2 if 'PSOIEN
QUIT ""
+3 SET GBL=$NAME(^TMP("CREQ^PSOERXX1",$JOB))
KILL @GBL
+4 SET CNT=0
+5 DO MSG^PSOERXX2(.GBL,1)
+6 ; header
+7 DO HDR^PSOERXX2(.GBL,PSOIEN)
+8 ; body header
+9 DO BHF^PSOERXX2(.GBL,1)
+10 ; request type header
+11 DO RTYPE^PSOERXX2(.GBL,"RxChangeRequest",1)
+12 ; request info
+13 DO REQUEST^PSOERXX2(.GBL,"TST","TST")
+14 DO VAPHARM^PSOERXX2(.GBL,PSOSITE,PSOIEN)
+15 DO PRESCRIB^PSOERXX2(.GBL,PSOIEN)
+16 DO SUPERVIS^PSOERXX2(.GBL,PSOIEN)
+17 DO FACIL^PSOERXX2(.GBL,PSOIEN)
+18 DO PATIENT^PSOERXX3(.GBL,PSOIEN)
+19 DO MEDPRES^PSOERXX4(.GBL,PSOIEN)
+20 DO MEDREQ^PSOERXX4(.GBL,PSOIEN,.REQDRUG)
+21 DO OBSERVE^PSOERXX3(.GBL,PSOIEN)
+22 DO BENEFITS^PSOERXX3(.GBL,PSOIEN)
+23 DO DRUGEVAL^PSOERXX3(.GBL,PSOIEN)
+24 DO DIAGNOS^PSOERXX3(.GBL,PSOIEN)
+25 DO RTYPE^PSOERXX2(.GBL,"RxChangeRequest",2)
+26 DO BHF^PSOERXX2(.GBL,2)
+27 DO MSG^PSOERXX2(.GBL,2)
+28 QUIT GBL
+29 ; FP - full or partial fill (F/P)
+30 ; NOTE - fill notes
RXFILL(PSOIEN,FP,NOTE,RXIEN,ORNUM) ;
+1 NEW GBL,PSOIENS,CNT
+2 if 'PSOIEN
QUIT ""
+3 SET GBL=$NAME(^TMP("RXFILL^PSOERXX1",$JOB))
KILL @GBL
+4 SET CNT=0
+5 DO MSG^PSOERXX2(.GBL,1)
+6 ; header
+7 DO HDR^PSOERXX2(.GBL,PSOIEN)
+8 ; body header
+9 DO BHF^PSOERXX2(.GBL,1)
+10 ; request type header
+11 DO RTYPE^PSOERXX2(.GBL,"RxFill",1)
+12 ; request info
+13 SET FP="F"
+14 SET NOTE=$GET(NOTE,"TESTING NOTES")
+15 ; fill status
+16 DO FILLST^PSOERXX3(.GBL,FP,NOTE)
+17 DO VAPHARM^PSOERXX2(.GBL,PSOIEN)
+18 DO PRESCRIB^PSOERXX2(.GBL,PSOIEN)
+19 DO SUPERVIS^PSOERXX2(.GBL,PSOIEN)
+20 DO FACIL^PSOERXX2(.GBL,PSOIEN)
+21 DO PATIENT^PSOERXX3(.GBL,PSOIEN)
+22 DO MEDPRES^PSOERXX4(.GBL,PSOIEN)
+23 DO MEDDIS^PSOERXX4(.GBL,PSOIEN)
+24 DO OBSERVE^PSOERXX3(.GBL,PSOIEN)
+25 DO BENEFITS^PSOERXX3(.GBL,PSOIEN)
+26 DO DRUGEVAL^PSOERXX3(.GBL,PSOIEN)
+27 ;D DIAGNOS^PSOERXX3(.GBL,PSOIEN)
+28 DO RTYPE^PSOERXX2(.GBL,"RxFill",2)
+29 DO BHF^PSOERXX2(.GBL,2)
+30 DO MSG^PSOERXX2(.GBL,2)
+31 QUIT GBL
DIRE ;
+1 NEW DIR
SET DIR(0)="E"
DO ^DIR
+2 QUIT
CONVXML(ARYNM) ;
+1 NEW F,F2,F3,F4,DATA
+2 SET F=0
FOR
SET F=$ORDER(@ARYNM@(F))
if F=""
QUIT
Begin DoDot:1
+3 SET F2=""
FOR
SET F2=$ORDER(@ARYNM@(F,F2))
if F2=""
QUIT
Begin DoDot:2
+4 SET F3=""
FOR
SET F3=$ORDER(@ARYNM@(F,F2,F3))
if F3=""
QUIT
Begin DoDot:3
+5 SET F4=""
FOR
SET F4=$ORDER(@ARYNM@(F,F2,F3,F4))
if F4=""
QUIT
Begin DoDot:4
+6 SET DATA=$GET(@ARYNM@(F,F2,F3,F4))
+7 SET DATA=$$SYMENC^MXMLUTL(DATA)
+8 SET @ARYNM@(F,F2,F3,F4)=DATA
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+9 QUIT
