PSOERX1H ;ALB/MFR - eRx Utilities ;Aug 14, 2020@12:43:34
;;7.0;OUTPATIENT PHARMACY;**700,746,770**;DEC 1997;Build 145
;
;Reference to NEW^TIUPNAPI in ICR #1911
;Reference to UPDATE^TIUSRVP in ICR #3535
;
DEANOTE ; DEA Note for CS Digitally Signed eRx records
S LINE=LINE+1 D SET^VALM10(LINE,"")
S LINE=LINE+1 D SET^VALM10(LINE,"This prescription meets the requirements of the Drug Enforcement Administration")
S LINE=LINE+1 D SET^VALM10(LINE,"(DEA) electronic prescribing for controlled substances rules (21 CFR Parts 1300,")
S LINE=LINE+1 D SET^VALM10(LINE,"1304, 1306, & 1311).")
Q
;
BATCHREM(ERXIEN,REMVIEN,REMCOMM,TYPE) ; Batch Remove/Un-Remove for Additional eRx (Received Same Day, Patient and Provider)
;Input: ERXIEN - eRx IEN (Pointer to #52.49)
; REMVIEN - Remove Code IEN (Pointer to #52.45)
; REMCOMM - Remove/Un-Remove Comments
; TYPE - R: Remove | U:Un-Remove
;Output: Marked eRx either Remove/Un-Remove
N MSGDTTM,EPRVIEN,EPATIEN,RECDAT,REMOVERX,REMVARR,MTYPE,NEWSTS,MSGTYPE,MBMSITE,RXSTAT,SKIPRX,TMPPSOIEN
S MBMSITE=$S($$GET1^DIQ(59.7,1,102,"I")="MBM":1,1:0)
S MSGDTTM=$$GET1^DIQ(52.49,ERXIEN,.03,"I")
S EPRVIEN=+$$GET1^DIQ(52.49,ERXIEN,2.1,"I")
S EPATIEN=+$$GET1^DIQ(52.49,ERXIEN,.04,"I")
S TMPPSOIEN=$G(PSOIEN)
S RECDAT=MSGDTTM\1
F S RECDAT=$O(^PS(52.49,"PAT2",EPATIEN,RECDAT)) Q:'RECDAT!((RECDAT\1)'=(MSGDTTM\1)) D
. S SKIPRX=0,REMOVERX=0 F S REMOVERX=$O(^PS(52.49,"PAT2",EPATIEN,RECDAT,REMOVERX)) Q:'REMOVERX D
. . I ERXIEN=REMOVERX Q
. . S RXSTAT=$$GET1^DIQ(52.49,REMOVERX,1,"E")
. . I TYPE="R" D Q:$G(SKIPRX)
. . . I RXSTAT="RJ"!(RXSTAT="RM")!($G(MBMSITE)&($E(RXSTAT,1,3)="REM"))!(RXSTAT="PR") S SKIPRX=1 Q
. . . S PSOIEN=REMOVERX I '$$OPACCESS^PSOERXU7("PSO ERX REMOVE",DUZ,REMOVERX) S SKIPRX=1
. . I TYPE="U" D Q:$G(SKIPRX)
. . . I REMVIEN=$$GET1^DIQ(52.49,REMOVERX,1,"I") S SKIPRX=1 Q
. . . D CHKSTA(REMOVERX) I RXSTAT'="RM" S SKIPRX=1
. . I EPRVIEN'=$$GET1^DIQ(52.49,REMOVERX,2.1,"I") Q
. . S REMVARR(REMOVERX)=REMOVERX
I '$D(REMVARR) Q
;
W !!,"The following prescriptions are from the same provider and received on the"
W !,"same day:",!
W !,"PROVIDER: "_$$GET1^DIQ(52.49,ERXIEN,2.1),?40,"eRx RECEIVED DATE: "_$$GET1^DIQ(52.49,ERXIEN,.03)
D LSTERXS^PSOERPT1(.REMVARR,0,0)
W !
N X,Y,DIR,DTOUT,DUOUT,DIROUT,DIRUT
S DIR(0)="Y",DIR("A")="Do you want to "
I TYPE="R" S DIR("A")=DIR("A")_"'Remove' them - "_$$GET1^DIQ(52.45,REMVIEN,.01)
I TYPE="U" S DIR("A")=DIR("A")_"'Un-Remove' them"
S DIR("B")="No" D ^DIR I '$G(Y) Q
;
W !,"Updating..."
S REMOVERX=0
F S REMOVERX=$O(REMVARR(REMOVERX)) Q:'REMOVERX D
. S NEWSTS=REMVIEN
. I TYPE="R" D UPDSTAT^PSOERXU1(REMOVERX,$S('$G(MBMSITE):"RM",1:$$GET1^DIQ(52.45,NEWSTS,.01)),REMCOMM)
. I TYPE="U" D UPDSTAT^PSOERXU1(REMOVERX,$$GET1^DIQ(52.45,NEWSTS,.01),REMCOMM)
H .5 W "done.",$C(7) H 1
I $G(TMPPSOIEN) S PSOIEN=TMPPSOIEN
Q
;
CHKSTA(REMOVERX) ; check if status is RM or type is "REM"
S STAIEN=+$G(^PS(52.49,REMOVERX,1)),RXSTAT=$P(^PS(52.45,STAIEN,0),"^",1)
I RXSTAT="RM" K STAIEN Q
S RXSTAT=$S($P(^PS(52.45,STAIEN,0),"^",3)="REM":"RM",1:"") K STAIEN
Q
CREATEPN(PSOIEN,CRERXIEN,PNCOMM,CRMEDS,TIUTITLE,ERXBTCHFLG) ;CREATE A PROGRESS NOTE FOR PATIENT
;Input : PSOIEN - Original eRx IEN (Pointer to #52.49)
; CRERXIEN - Change Request eRx IEN (Pointer to #52.49)
; PNCOMM - Additional Progress Note Comments
; Example: This is a sample addtional VA Pharmacy Progress Note Comments.
; CRMEDS - Input array passed by reference.
; This is an array of the eRx change request medication list.
; TIUTITLE - The TIU Document Definitiona name in File #8925.1
; (o) ERXBTCHFLG - 1: If erx batch change request | 0 or NULL: Otherwise
;Output: Update existing TIU Document for the Patient
N TARGET,PSODFN,PSOPTNM,PSOTITL,PSOTIUDA,CRFDA
;
I $G(PSOIEN)=""!($G(CRERXIEN)="")!($G(TIUTITLE)="") Q
Q:",CX,CR,"'[(","_$P($$ERXMTYPE^PSOERSE1(CRERXIEN),"^")_",")
S TARGET=$NA(^TMP("TIUP",$J)) K @TARGET
I $$GET1^DIQ(52.49,CRERXIEN,.08,"I")="CR" W !,$S($G(ERXBTCHFLG):" ",1:"")_"Creating a new Progress Note..."
D BUILDLST^PSOERSE4(TARGET,CRERXIEN,$G(PNCOMM))
S PSOTITL=$$FIND1^DIC(8925.1,"","X",TIUTITLE,"B")
Q:'+PSOTITL ;IF NO TITLE ON SYSTEM
S PSODFN=$$GET1^DIQ(52.49,PSOIEN,.05,"I")
I 'PSODFN S PSODFN=$$GET1^DIQ(52,+$$GET1^DIQ(52.49,PSOIEN,.13,"I"),2,"I") I 'PSODFN Q
S PSOPTNM=$P($G(^DPT(PSODFN,0)),U,1)
D NEW^TIUPNAPI(.PSOTIUDA,PSODFN,DUZ,$$NOW^XLFDT,PSOTITL,$G(PSOCLNC))
I +$G(PSOTIUDA)<0 D Q
. I $$GET1^DIQ(52.49,CRERXIEN,.08,"I")="CR" W !,$G(IOINHI),"A problem was encountered while creating the Progress Note.",$G(IOINORM),$C(7),! H 3
N TIUX D UPDATESUB(+$G(PSOTIUDA),PSOIEN,.CRMEDS)
D MARKSIGN(PSOTIUDA,DUZ) ;this API triggers to electronically signed the document and send an alert to the co-signature recipient
S CRFDA(52.49,CRERXIEN_",",320.1)=+$G(PSOTIUDA) ;parent TIU IEN reference number for eRx Change Request
I $G(PNCOMM)'="" S CRFDA(52.49,CRERXIEN_",",320.2)=$G(PNCOMM) ;VA Pharmacy Progress Notes
D FILE^DIE(,"CRFDA") K CRFDA
I $$GET1^DIQ(52.49,CRERXIEN,.08,"I")="CR" W "Done." H .5
Q
;
UPDATESUB(PSOTIUDA,PSOIEN,CRMEDS) ;Update Subject of the existing patient progress notes
;Input : PSOTIUDA - TIU IEN (Pointer to #8925)
; PSOIEN - Original eRx IEN (Pointer to #52.49)
; CRMEDS - Input array passed by reference.
; This is an array of the eRx change request medication list.
;Output: Update existing TIU Document for the Patient
;
N ERXRET,SUBJECT,CNTR,ERXDRUG,DRUGNAME
Q:$G(PSOTIUDA)=""
S ERXDRUG=$$GET1^DIQ(52.49,PSOIEN,3.1,"E") ;get the drugname first from the original erx
I '$L(ERXDRUG) S ERXDRUG=$$GETDRUG^PSOERXU5(PSOIEN)
S SUBJECT=$P(ERXDRUG," ")
I $O(CRMEDS(0)) D
. S CNTR=0,SUBJECT=SUBJECT_":"
. F S CNTR=$O(CRMEDS(CNTR)) Q:CNTR="" D
. . S DRUGNAME=$P($P(CRMEDS(CNTR),U,2)," ")
. . I $P(SUBJECT,":",2)'[DRUGNAME S SUBJECT=SUBJECT_DRUGNAME_","
. S $E(SUBJECT,$L(SUBJECT))=""
. I $L(SUBJECT)>80 S SUBJECT=$E(SUBJECT,1,77)_"..."
;
S TIUX(1701)=$S($L(SUBJECT)>80:$E(SUBJECT,1,61)_"...",1:SUBJECT)
D UPDATE^TIUSRVP(.ERXRET,PSOTIUDA,.TIUX) ;Update the SUBJECT of this document
Q
;
MARKSIGN(TIUDA,TIUESBY) ; Mark note as electronically signed and send alert to the co-signature recipient
;Input : TIUDA - TIU IEN (Pointer to #8925)
; TIUESBY - User DUZ (Pointer to #200)
N ESNAME,ESTITLE,ESBLOCK
I $S(+$G(TIUESBY)'>0:1,$L($$GET1^DIQ(200,+$G(TIUESBY),.01))'>0:1,+$$CANDO^TIULP(TIUDA,"SIGNATURE",$G(TIUESBY))'>0:1,1:0) S TIUDA=TIUDA_U_-1 Q
S ESNAME=$$GET1^DIQ(200,+TIUESBY,20.2),ESTITLE=$$GET1^DIQ(200,+TIUESBY,20.3)
S ESBLOCK="1^"_ESNAME_U_ESTITLE
D ES^TIURS(TIUDA,ESBLOCK)
I +$P(^TIU(8925,+TIUDA,0),U,5)<6 S TIUDA=TIUDA_"^-1"
Q
;
UPDATEPN(PSOTIUDA,PSOIEN) ;Update existing patient progress notes
;Input : PSOTIUDA - TIU IEN (Pointer to #8925)
; PSOIEN - Original eRx IEN (Pointer to #52.49)
N TIUX
S TIUX(.05)=$$FIND1^DIC(8925.6,"","X","COMPLETED","B")
S TIUX(1501)=$$NOW^XLFDT()
S TIUX(1502)=DUZ
S TIUX(1503)=$$GET1^DIQ(200,+DUZ,20.2)
S TIUX(1504)=$$GET1^DIQ(200,+DUZ,20.3)
S TIUX(1505)="E"
D UPDATESUB(+$G(PSOTIUDA),PSOIEN)
Q
;
DRUGHDR ; - Drug Matching Header Line
S AMATCH=$$GET1^DIQ(52.49,ERXIEN,1.4,"I")
S VALUSER=$$GET1^DIQ(52.49,ERXIEN,1.11,"E"),VALDTTM=$$GET1^DIQ(52.49,ERXIEN,1.12,"I")
I $$GET1^DIQ(52.49,ERXIEN,.08,"I")="RE",'VALDTTM D
. S MATCH="PREVIOUSLY MATCHED/VALIDATED (RENEWAL)"
E D
. S MATCH=$S(AMATCH=1:"SUGGESTED",AMATCH=2:"SUGGESTED/EDITED",VADRGIEN:"MANUAL ENTRY",1:"")
. I VALUSER'="",MATCH'="" S MATCH=MATCH_" | VALIDATED by "_$E(VALUSER,1,19)_" on "_$$FMTE^XLFDT(VALDTTM*10000\1/10000,"2Y")
. I MATCH="" S MATCH="NOT MATCHED"
S MATCH="DRUG/SIG "_MATCH I $L(MATCH)>78 S MATCH=$E(MATCH,1,78)
S HDR="",$E(HDR,(80-$L(MATCH))\2+1)=MATCH,$E(HDR,81)=""
S $E(MATCH,81)=""
S UNDERLN(LINE,1)=100 I HDR["/EDITED" S BLINKLN(LINE,$F(HDR,"/EDITED")-6)=6
D ADDLINE^PSOERUT0("LM",NMSPC,HDR,"")
Q
;
ADDPNOTE(LINE,PNCOMM) ;
N DUZTITLE
S LINE=LINE+1 S @TMPGBL@(LINE,0)=""
S LINE=LINE+1 S @TMPGBL@(LINE,0)=PNCOMM
S LINE=LINE+1 S @TMPGBL@(LINE,0)=""
S LINE=LINE+1 S @TMPGBL@(LINE,0)="Provider's feedback pending."
S LINE=LINE+1 S @TMPGBL@(LINE,0)=""
Q
;
CHECKREC(RECARY) ;check if there are any change requests made for this original eRx.
;Input : RECARY - A pass by reference variable name of the array that contain all eRx already been sent
;Output: SELCTREC - Selected option: N for New or R for Resend
; If R, it will be concatenated with the entry # to resend.
N RECCNT,RECIEN,DDASH,ERXHUBID,ERXTYPE,ERXSTAT,ERXDTM,CNTR,RECENTRY
I $D(RECARY) D
. W !,"#",?5,"ERX ID",?21,"ERX TYPE",?40,"STATUS",?50,"DATE/TIME"
. S $P(DDASH,"-",81)="" W !,DDASH
. S CNTR=0
. F S CNTR=$O(RECARY(CNTR)) Q:'CNTR D
. . S RECIEN=RECARY(CNTR)
. . S ERXHUBID=$P($G(^PS(52.49,RECIEN,0)),"^",1)
. . S ERXTYPE=$$GET1^DIQ(52.49,RECIEN,.08,"E")
. . S ERXSTAT=$$GET1^DIQ(52.49,RECIEN,1,"E")
. . S ERXDTM=$$GET1^DIQ(52.49,RECIEN,.03,"I"),ERXDTM=$$FMTE^XLFDT(ERXDTM,1)
. . W !,CNTR,?5,ERXHUBID,?21,ERXTYPE,?40,ERXSTAT,?50,ERXDTM
. . S RECCNT=CNTR
. S SELCTREC=$$SELCTREC
. I SELCTREC="R" D
. . K DIR S DIR(0)="LO^1:"_RECCNT,DIR("A")="Select Entry # to Resend"
. . W ! D ^DIR I $D(DIRUT)!$D(DIROUT) Q
. . S RECENTRY=+Y
Q $G(SELCTREC)_$S($G(SELCTREC)="R":$G(RECENTRY),1:"")
;
SELCTREC() ;prompt user to select REC
; N - New
; R - Resend existing REC
N PSOASK,PSODIRA,PSODIRB,PSODIRH,PSODIR0
W !
S PSODIRA="Select Suggestion Option: (N)EW (R)ESEND: "
S PSODIRB=""
S PSODIRH="^D HELP^PSOERX1H"
S PSODIR0="SOA^N:NEW;R:RESEND"
S PSOASK=$$ANSWER(PSODIRA,PSODIRB,PSODIR0,PSODIRH)
Q $G(PSOASK)
;
ANSWER(PSODIRA,PSODIRB,PSODIR0,PSODIRH) ;
; Input:
; PSODIR0 - DIR(0) string
; PSODIRA - DIR("A") string
; PSODIRB - DIR("B") string
; PSODIRH - DIR("?") string
; Output:
; Function Value - Internal value returned from ^DIR or -1 if user
; up-arrows, double up-arrows or the read times out.
N X,Y,Z,DIR,DIROUT,DIRUT,DTOUT,DUOUT
I $D(PSODIR0) S DIR(0)=PSODIR0
I $D(PSODIRA) S DIR("A")=PSODIRA
I $G(PSODIRB)]"" S DIR("B")=PSODIRB
I $D(PSODIRH) S DIR("?")=PSODIRH,DIR("??")=PSODIRH
D ^DIR
S Z=$S($D(DTOUT):-2,$D(DUOUT):-1,$D(DIROUT):-1,1:"")
I Z="" S Z=$S(Y=-1:"",X="@":"@",1:$P(Y,U)) Q Z
I $D(DTOUT)!$D(DUOUT)!$D(DIROUT) Q -1
Q $S(X="@":"@",1:$P(Y,U))
;
HELP ;REC help
I X="?"!(X="??") D
. W !!,"NEW - Adds a new Drug/SIG/Qty/Refills/Days Supply suggestion be sent to"
. W " the prescriber as an alternative for this Change Request.",!
. W !,"RESEND - Allow users to edit and resend an eRx Change Request."
Q
;
BUILDSUM(ERXIEN) ;Build the existing record of the erx that the user selected
;Input - eRx IEN (Pointer to #52.49)
;Output - None
N IENS,RSNTXT,X,RET,INDEX,CODE,Y
K INDEX S CODE=0
F S CODE=$O(^PS(52.45,"TYPE","MRC",CODE)) Q:'CODE S INDEX($$GET1^DIQ(52.45,CODE,.01))=CODE
S REACODE=$$GET1^DIQ(52.49,ERXIEN,315.1,"I"),Y=$$GET1^DIQ(52.49,ERXIEN,315.1,"E")
I $G(REACODE)'=+$G(INDEX(Y)) S REASCODE=0,EXTSCODE="" K REATXT
S REACODE=+$G(INDEX(Y)),EXTRCODE=$$GET1^DIQ(52.45,REACODE,.01)
S IENS=$O(^PS(52.49,ERXIEN,316,0))
I IENS D
. S IENS=IENS_","_ERXIEN_","
. S REASCODE=$$GET1^DIQ(52.49316,IENS,1,"I")
. S EXTSCODE=$$GET1^DIQ(52.45,REASCODE,.01)
. S EXTRCODE=$$GET1^DIQ(52.45,REACODE,.01)
I '$G(IENS) S EXTSCODE=""
S RSNTXT=$$GET1^DIQ(52.49,ERXIEN,317,,"REATXT")
I $G(REATXT(1))'="" D
. S X=REATXT(1) K RET D TXT2ARY^PSOERXD1(.RET,X," ",80)
. K REATXT M REATXT=RET
D MEDREQ(ERXIEN)
Q
;
MEDREQ(ERXIEN) ;Existing Medication Requested
;Input - eRx IEN (Pointer to #52.49)
;Output - CRMEDS array containing the medication requested
N FILE,I,II,IENS,MEDREQ,DRUG,DRUGCODE,DRUGCODQ,SUBS,NOTE,QTYQUAL,QTY,NUMREFS,QUOM,CRMED,ERXSIG,X
K ^TMP("PSOCRSIG",$J),CRMEDS
S II=0
F S II=$O(^PS(52.49,ERXIEN,311,II)) Q:'II D ;Only requested medications
. S FILE=52.49311,IENS=II_","_ERXIEN_","
. K MEDREQ D GETS^DIQ(FILE,IENS,"**","IE","MEDREQ")
. I $G(MEDREQ(FILE,IENS,.02,"I"))="R" D
. . S DRUG=$G(MEDREQ(FILE,IENS,.03,"E"))
. . S DRUGTYPE=$S($G(MEDREQ(FILE,IENS,1.2,"E"))="ND":"V",1:"E")
. . S DRUGCODE=$G(MEDREQ(FILE,IENS,1.1,"E"))
. . S DRUGCODQ=$G(MEDREQ(FILE,IENS,1.2,"E"))
. . S SUBS=$G(MEDREQ(FILE,IENS,2.7,"I"))
. . S NOTE=$G(MEDREQ(FILE,IENS,5,"E"))
. . S QTYQUAL=$G(MEDREQ(FILE,IENS,2.2,"E"))
. . S QTYUM=$G(MEDREQ(FILE,IENS,2.3,"E"))
. . S QTY=$G(MEDREQ(FILE,IENS,2.1,"E"))
. . S NUMREFS=$G(MEDREQ(FILE,IENS,2.8,"E"))
. . S DAYSSUP=$G(MEDREQ(FILE,IENS,2.4,"E"))
. . S QUOM=$G(MEDREQ(FILE,IENS,2.3,"I"))
. . S QUOM=$$GET1^DIQ(52.45,QUOM,.02,"E")
. . S CRMED=$O(CRMEDS(99),-1)+1
. . S CRMEDS(CRMED)=DRUGTYPE_"^"_DRUG_"^"_DRUGCODE_"^"_DRUGCODQ_"^"_SUBS_"^"_QTY_"^"_QTYQUAL_"^"_QTYUM_"^"_DAYSSUP_"^"_NUMREFS
. . S CRMEDS(CRMED,"NOTE")=NOTE
. . S X=$$GET1^DIQ(FILE,IENS,8,,"ERXSIG")
. . F I=1:1 Q:'$D(ERXSIG(I)) S ^TMP("PSOCRSIG",$J,I,0)=ERXSIG(I)
. . M CRMEDS(CRMED,"SIG")=^TMP("PSOCRSIG",$J)
Q
;
UNACC ; Un-Accept eRx from Pending Queue back into the Holding Queue
N ORDNUM,ERXIEN,PSOIEN,DIE,DA,DR,DIC,PSOHOLD,PSOQUIT,DIR,X,Y,DTOUT,DUOUT,HOLDCOMM,POERR
S VALMBCK="R"
I '$G(ORD)!'$D(^PS(52.41,+$G(ORD),0)) S VALMSG="Invalid Pending Order" W $C(7) Q
I " NW RNW "'[$$GET1^DIQ(52.41,ORD,2,"I") S VALMSG="eRx has already been finished or un-accepted." W $C(7) Q
S ORDNUM=$$GET1^DIQ(52.41,+ORD,.01) I 'ORDNUM S VALMSG="Invalid Pending Order" W $C(7) Q
S (ERXIEN,PSOIEN)=$$CHKERX^PSOERXU1(ORDNUM) I 'PSOIEN S VALMSG="This Pending Order is not related to an eRx" W $C(7) Q
I '$G(ERXIEN) S VALMSG="This is not an eRx Prescription" W $C(7) Q
D FULL^VALM1
;
K DIC W ! S DIC("A")="Select HOLD reason code: "
S DIC="^PS(52.45,",DIC(0)="AEMQ",DIC("B")="HOLD FOR RX EDIT"
S DIC("S")="I $D(^PS(52.45,""TYPE"",""ERX"",Y)),$E($P(^PS(52.45,Y,0),U),1)=""H"""
S (PSOHOLD,PSOQUIT)=0
F D ^DIC D I PSOHOLD!PSOQUIT Q
. I $G(DUOUT)!$G(DTOUT) S PSOQUIT=1 Q
. I X="" W !,"HOLD Reason is required",!,$C(7) Q
. S PSOHOLD=Y
I $P(PSOHOLD,"^",2)="HFF" D I $D(DIRUT)!$D(DIROUT) Q
. W !!,$G(IOINHI),"The eRx will be un-held automatically on the date you enter below and placed"
. W !,"in 'WAIT' status.",$G(IOINORM)
. K DIR W ! S DIR(0)="DA^"_$$FMADD^XLFDT(DT,1)_":"_$$FMADD^XLFDT($$GET1^DIQ(52.49,PSOIEN,5.9,"I"),$S($$GET1^DIQ(52.49,PSOIEN,95.1,"I"):184,1:366))_":EX"
. I $$EFFDATE^PSOERXU5(ERXIEN,1)'="" S DIR("B")=$$FMTE^XLFDT($$EFFDATE^PSOERXU5(ERXIEN,1))
. S DIR("A")="Future Fill Hold Date: " D ^DIR I $D(DIRUT)!$D(DIROUT) Q
. S HFFDT=Y
I PSOQUIT Q
;
K DIR,DA S DIR(0)="52.4919,1",DIR("A")="Comments (Optional)"
D ^DIR K DIR I Y="^" Q
S HOLDCOMM=$G(Y)
;
K DIR W ! S DIR("A",1)="This eRx will be Un-Accepted and sent back to the eRx Holding Queue."
S DIR("A",2)="",DIR("A")="Confirm",DIR(0)="Y",DIR("B")="N"
D ^DIR I $G(DIRUT)!$G(DUOUT)!'Y Q
W ?40,"Please wait..."
;
; Changing eRx Order Status to Hold
D UPDSTAT^PSOERXU1(ERXIEN,$P(PSOHOLD,"^",2),HOLDCOMM,1,,$G(HFFDT))
; Removing pointer to the Pending Order entry
I $P($G(^PS(52.49,ERXIEN,25)),"^",2) S $P(^PS(52.49,ERXIEN,25),"^",2)=""
;
Q:'$D(^PS(52.41,ORD,0))
K ^PS(52.41,"AOR",$P(^PS(52.41,ORD,0),"^",2),+$P($G(^PS(52.41,ORD,"INI")),"^"),ORD)
K ^PS(52.41,"AD",$P(^PS(52.41,ORD,0),"^",12),+$P($G(^PS(52.41,ORD,"INI")),"^"),ORD)
S $P(^PS(52.41,ORD,0),"^",3)="DC",POERR("PLACER")=$P(^(0),"^"),POERR("STAT")="OC"
S POERR("COMM")="eRx Un-Accepted: "_$$GET1^DIQ(52.45,+PSOHOLD,.02)_$S(HOLDCOMM'="":" - "_HOLDCOMM,1:"")
S $P(^PS(52.41,ORD,4),"^")=POERR("COMM")
D EN^PSOHLSN(POERR("PLACER"),POERR("STAT"),POERR("COMM"),"W")
;
W !!,"eRx successfully un-accepted and placed back on the eRx Holding Queue."
K DIR D PAUSE^VALM1
;
D JUMP2ERX^PSOERX1I K VALMBCK
Q
;
UNACCBEF(ERXIEN) ; Determines if the eRx has been Un-Accepted Before
; Input: (r)ERXIEN - Pointer to ERX HOLDING QUEUE (#52.49)
;Output: P1: 1 - eRx has been Un-Accepted Before | 0 - Never been Un-Accepted
; P2: Un-Accepted by (if P1 = 1)
; P3: Un-Accepted date/time (if P1 = 1)
; Example: 1^LASTNAME,FIRSTNAME^9/26/24@10:30
N UNACCBEF,STSHST
S UNACCBEF=0
S STSHST=9999 F S STSHST=$O(^PS(52.49,ERXIEN,19,STSHST),-1) Q:'STSHST D I UNACCBEF Q
. S UNACCBEF=+$$GET1^DIQ(52.4919,STSHST_","_ERXIEN,.04,"I")
. I UNACCBEF S $P(UNACCBEF,"^",2,3)=$E($$GET1^DIQ(52.4919,STSHST_","_ERXIEN,.03),1,16)_"^"_$$FMTE^XLFDT($$GET1^DIQ(52.4919,STSHST_","_ERXIEN,.01,"I"),"2Y")
Q UNACCBEF
;
ASKCONT ; display "Press <Enter> or '^' to exit" prompt
N Z
W !,$$CJ^XLFSTR("Press <Enter> or '^' to exit.",1)
R Z:DTIME
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOERX1H 16962 printed Aug 26, 2025@22:44:23 Page 2
PSOERX1H ;ALB/MFR - eRx Utilities ;Aug 14, 2020@12:43:34
+1 ;;7.0;OUTPATIENT PHARMACY;**700,746,770**;DEC 1997;Build 145
+2 ;
+3 ;Reference to NEW^TIUPNAPI in ICR #1911
+4 ;Reference to UPDATE^TIUSRVP in ICR #3535
+5 ;
DEANOTE ; DEA Note for CS Digitally Signed eRx records
+1 SET LINE=LINE+1
DO SET^VALM10(LINE,"")
+2 SET LINE=LINE+1
DO SET^VALM10(LINE,"This prescription meets the requirements of the Drug Enforcement Administration")
+3 SET LINE=LINE+1
DO SET^VALM10(LINE,"(DEA) electronic prescribing for controlled substances rules (21 CFR Parts 1300,")
+4 SET LINE=LINE+1
DO SET^VALM10(LINE,"1304, 1306, & 1311).")
+5 QUIT
+6 ;
BATCHREM(ERXIEN,REMVIEN,REMCOMM,TYPE) ; Batch Remove/Un-Remove for Additional eRx (Received Same Day, Patient and Provider)
+1 ;Input: ERXIEN - eRx IEN (Pointer to #52.49)
+2 ; REMVIEN - Remove Code IEN (Pointer to #52.45)
+3 ; REMCOMM - Remove/Un-Remove Comments
+4 ; TYPE - R: Remove | U:Un-Remove
+5 ;Output: Marked eRx either Remove/Un-Remove
+6 NEW MSGDTTM,EPRVIEN,EPATIEN,RECDAT,REMOVERX,REMVARR,MTYPE,NEWSTS,MSGTYPE,MBMSITE,RXSTAT,SKIPRX,TMPPSOIEN
+7 SET MBMSITE=$SELECT($$GET1^DIQ(59.7,1,102,"I")="MBM":1,1:0)
+8 SET MSGDTTM=$$GET1^DIQ(52.49,ERXIEN,.03,"I")
+9 SET EPRVIEN=+$$GET1^DIQ(52.49,ERXIEN,2.1,"I")
+10 SET EPATIEN=+$$GET1^DIQ(52.49,ERXIEN,.04,"I")
+11 SET TMPPSOIEN=$GET(PSOIEN)
+12 SET RECDAT=MSGDTTM\1
+13 FOR
SET RECDAT=$ORDER(^PS(52.49,"PAT2",EPATIEN,RECDAT))
if 'RECDAT!((RECDAT\1)'=(MSGDTTM\1))
QUIT
Begin DoDot:1
+14 SET SKIPRX=0
SET REMOVERX=0
FOR
SET REMOVERX=$ORDER(^PS(52.49,"PAT2",EPATIEN,RECDAT,REMOVERX))
if 'REMOVERX
QUIT
Begin DoDot:2
+15 IF ERXIEN=REMOVERX
QUIT
+16 SET RXSTAT=$$GET1^DIQ(52.49,REMOVERX,1,"E")
+17 IF TYPE="R"
Begin DoDot:3
+18 IF RXSTAT="RJ"!(RXSTAT="RM")!($GET(MBMSITE)&($EXTRACT(RXSTAT,1,3)="REM"))!(RXSTAT="PR")
SET SKIPRX=1
QUIT
+19 SET PSOIEN=REMOVERX
IF '$$OPACCESS^PSOERXU7("PSO ERX REMOVE",DUZ,REMOVERX)
SET SKIPRX=1
End DoDot:3
if $GET(SKIPRX)
QUIT
+20 IF TYPE="U"
Begin DoDot:3
+21 IF REMVIEN=$$GET1^DIQ(52.49,REMOVERX,1,"I")
SET SKIPRX=1
QUIT
+22 DO CHKSTA(REMOVERX)
IF RXSTAT'="RM"
SET SKIPRX=1
End DoDot:3
if $GET(SKIPRX)
QUIT
+23 IF EPRVIEN'=$$GET1^DIQ(52.49,REMOVERX,2.1,"I")
QUIT
+24 SET REMVARR(REMOVERX)=REMOVERX
End DoDot:2
End DoDot:1
+25 IF '$DATA(REMVARR)
QUIT
+26 ;
+27 WRITE !!,"The following prescriptions are from the same provider and received on the"
+28 WRITE !,"same day:",!
+29 WRITE !,"PROVIDER: "_$$GET1^DIQ(52.49,ERXIEN,2.1),?40,"eRx RECEIVED DATE: "_$$GET1^DIQ(52.49,ERXIEN,.03)
+30 DO LSTERXS^PSOERPT1(.REMVARR,0,0)
+31 WRITE !
+32 NEW X,Y,DIR,DTOUT,DUOUT,DIROUT,DIRUT
+33 SET DIR(0)="Y"
SET DIR("A")="Do you want to "
+34 IF TYPE="R"
SET DIR("A")=DIR("A")_"'Remove' them - "_$$GET1^DIQ(52.45,REMVIEN,.01)
+35 IF TYPE="U"
SET DIR("A")=DIR("A")_"'Un-Remove' them"
+36 SET DIR("B")="No"
DO ^DIR
IF '$GET(Y)
QUIT
+37 ;
+38 WRITE !,"Updating..."
+39 SET REMOVERX=0
+40 FOR
SET REMOVERX=$ORDER(REMVARR(REMOVERX))
if 'REMOVERX
QUIT
Begin DoDot:1
+41 SET NEWSTS=REMVIEN
+42 IF TYPE="R"
DO UPDSTAT^PSOERXU1(REMOVERX,$SELECT('$GET(MBMSITE):"RM",1:$$GET1^DIQ(52.45,NEWSTS,.01)),REMCOMM)
+43 IF TYPE="U"
DO UPDSTAT^PSOERXU1(REMOVERX,$$GET1^DIQ(52.45,NEWSTS,.01),REMCOMM)
End DoDot:1
+44 HANG .5
WRITE "done.",$CHAR(7)
HANG 1
+45 IF $GET(TMPPSOIEN)
SET PSOIEN=TMPPSOIEN
+46 QUIT
+47 ;
CHKSTA(REMOVERX) ; check if status is RM or type is "REM"
+1 SET STAIEN=+$GET(^PS(52.49,REMOVERX,1))
SET RXSTAT=$PIECE(^PS(52.45,STAIEN,0),"^",1)
+2 IF RXSTAT="RM"
KILL STAIEN
QUIT
+3 SET RXSTAT=$SELECT($PIECE(^PS(52.45,STAIEN,0),"^",3)="REM":"RM",1:"")
KILL STAIEN
+4 QUIT
CREATEPN(PSOIEN,CRERXIEN,PNCOMM,CRMEDS,TIUTITLE,ERXBTCHFLG) ;CREATE A PROGRESS NOTE FOR PATIENT
+1 ;Input : PSOIEN - Original eRx IEN (Pointer to #52.49)
+2 ; CRERXIEN - Change Request eRx IEN (Pointer to #52.49)
+3 ; PNCOMM - Additional Progress Note Comments
+4 ; Example: This is a sample addtional VA Pharmacy Progress Note Comments.
+5 ; CRMEDS - Input array passed by reference.
+6 ; This is an array of the eRx change request medication list.
+7 ; TIUTITLE - The TIU Document Definitiona name in File #8925.1
+8 ; (o) ERXBTCHFLG - 1: If erx batch change request | 0 or NULL: Otherwise
+9 ;Output: Update existing TIU Document for the Patient
+10 NEW TARGET,PSODFN,PSOPTNM,PSOTITL,PSOTIUDA,CRFDA
+11 ;
+12 IF $GET(PSOIEN)=""!($GET(CRERXIEN)="")!($GET(TIUTITLE)="")
QUIT
+13 if ",CX,CR,"'[(","_$PIECE($$ERXMTYPE^PSOERSE1(CRERXIEN),"^")_",")
QUIT
+14 SET TARGET=$NAME(^TMP("TIUP",$JOB))
KILL @TARGET
+15 IF $$GET1^DIQ(52.49,CRERXIEN,.08,"I")="CR"
WRITE !,$SELECT($GET(ERXBTCHFLG):" ",1:"")_"Creating a new Progress Note..."
+16 DO BUILDLST^PSOERSE4(TARGET,CRERXIEN,$GET(PNCOMM))
+17 SET PSOTITL=$$FIND1^DIC(8925.1,"","X",TIUTITLE,"B")
+18 ;IF NO TITLE ON SYSTEM
if '+PSOTITL
QUIT
+19 SET PSODFN=$$GET1^DIQ(52.49,PSOIEN,.05,"I")
+20 IF 'PSODFN
SET PSODFN=$$GET1^DIQ(52,+$$GET1^DIQ(52.49,PSOIEN,.13,"I"),2,"I")
IF 'PSODFN
QUIT
+21 SET PSOPTNM=$PIECE($GET(^DPT(PSODFN,0)),U,1)
+22 DO NEW^TIUPNAPI(.PSOTIUDA,PSODFN,DUZ,$$NOW^XLFDT,PSOTITL,$GET(PSOCLNC))
+23 IF +$GET(PSOTIUDA)<0
Begin DoDot:1
+24 IF $$GET1^DIQ(52.49,CRERXIEN,.08,"I")="CR"
WRITE !,$GET(IOINHI),"A problem was encountered while creating the Progress Note.",$GET(IOINORM),$CHAR(7),!
HANG 3
End DoDot:1
QUIT
+25 NEW TIUX
DO UPDATESUB(+$GET(PSOTIUDA),PSOIEN,.CRMEDS)
+26 ;this API triggers to electronically signed the document and send an alert to the co-signature recipient
DO MARKSIGN(PSOTIUDA,DUZ)
+27 ;parent TIU IEN reference number for eRx Change Request
SET CRFDA(52.49,CRERXIEN_",",320.1)=+$GET(PSOTIUDA)
+28 ;VA Pharmacy Progress Notes
IF $GET(PNCOMM)'=""
SET CRFDA(52.49,CRERXIEN_",",320.2)=$GET(PNCOMM)
+29 DO FILE^DIE(,"CRFDA")
KILL CRFDA
+30 IF $$GET1^DIQ(52.49,CRERXIEN,.08,"I")="CR"
WRITE "Done."
HANG .5
+31 QUIT
+32 ;
UPDATESUB(PSOTIUDA,PSOIEN,CRMEDS) ;Update Subject of the existing patient progress notes
+1 ;Input : PSOTIUDA - TIU IEN (Pointer to #8925)
+2 ; PSOIEN - Original eRx IEN (Pointer to #52.49)
+3 ; CRMEDS - Input array passed by reference.
+4 ; This is an array of the eRx change request medication list.
+5 ;Output: Update existing TIU Document for the Patient
+6 ;
+7 NEW ERXRET,SUBJECT,CNTR,ERXDRUG,DRUGNAME
+8 if $GET(PSOTIUDA)=""
QUIT
+9 ;get the drugname first from the original erx
SET ERXDRUG=$$GET1^DIQ(52.49,PSOIEN,3.1,"E")
+10 IF '$LENGTH(ERXDRUG)
SET ERXDRUG=$$GETDRUG^PSOERXU5(PSOIEN)
+11 SET SUBJECT=$PIECE(ERXDRUG," ")
+12 IF $ORDER(CRMEDS(0))
Begin DoDot:1
+13 SET CNTR=0
SET SUBJECT=SUBJECT_":"
+14 FOR
SET CNTR=$ORDER(CRMEDS(CNTR))
if CNTR=""
QUIT
Begin DoDot:2
+15 SET DRUGNAME=$PIECE($PIECE(CRMEDS(CNTR),U,2)," ")
+16 IF $PIECE(SUBJECT,":",2)'[DRUGNAME
SET SUBJECT=SUBJECT_DRUGNAME_","
End DoDot:2
+17 SET $EXTRACT(SUBJECT,$LENGTH(SUBJECT))=""
+18 IF $LENGTH(SUBJECT)>80
SET SUBJECT=$EXTRACT(SUBJECT,1,77)_"..."
End DoDot:1
+19 ;
+20 SET TIUX(1701)=$SELECT($LENGTH(SUBJECT)>80:$EXTRACT(SUBJECT,1,61)_"...",1:SUBJECT)
+21 ;Update the SUBJECT of this document
DO UPDATE^TIUSRVP(.ERXRET,PSOTIUDA,.TIUX)
+22 QUIT
+23 ;
MARKSIGN(TIUDA,TIUESBY) ; Mark note as electronically signed and send alert to the co-signature recipient
+1 ;Input : TIUDA - TIU IEN (Pointer to #8925)
+2 ; TIUESBY - User DUZ (Pointer to #200)
+3 NEW ESNAME,ESTITLE,ESBLOCK
+4 IF $SELECT(+$GET(TIUESBY)'>0:1,$LENGTH($$GET1^DIQ(200,+$GET(TIUESBY),.01))'>0:1,+$$CANDO^TIULP(TIUDA,"SIGNATURE",$GET(TIUESBY))'>0:1,1:0)
SET TIUDA=TIUDA_U_-1
QUIT
+5 SET ESNAME=$$GET1^DIQ(200,+TIUESBY,20.2)
SET ESTITLE=$$GET1^DIQ(200,+TIUESBY,20.3)
+6 SET ESBLOCK="1^"_ESNAME_U_ESTITLE
+7 DO ES^TIURS(TIUDA,ESBLOCK)
+8 IF +$PIECE(^TIU(8925,+TIUDA,0),U,5)<6
SET TIUDA=TIUDA_"^-1"
+9 QUIT
+10 ;
UPDATEPN(PSOTIUDA,PSOIEN) ;Update existing patient progress notes
+1 ;Input : PSOTIUDA - TIU IEN (Pointer to #8925)
+2 ; PSOIEN - Original eRx IEN (Pointer to #52.49)
+3 NEW TIUX
+4 SET TIUX(.05)=$$FIND1^DIC(8925.6,"","X","COMPLETED","B")
+5 SET TIUX(1501)=$$NOW^XLFDT()
+6 SET TIUX(1502)=DUZ
+7 SET TIUX(1503)=$$GET1^DIQ(200,+DUZ,20.2)
+8 SET TIUX(1504)=$$GET1^DIQ(200,+DUZ,20.3)
+9 SET TIUX(1505)="E"
+10 DO UPDATESUB(+$GET(PSOTIUDA),PSOIEN)
+11 QUIT
+12 ;
DRUGHDR ; - Drug Matching Header Line
+1 SET AMATCH=$$GET1^DIQ(52.49,ERXIEN,1.4,"I")
+2 SET VALUSER=$$GET1^DIQ(52.49,ERXIEN,1.11,"E")
SET VALDTTM=$$GET1^DIQ(52.49,ERXIEN,1.12,"I")
+3 IF $$GET1^DIQ(52.49,ERXIEN,.08,"I")="RE"
IF 'VALDTTM
Begin DoDot:1
+4 SET MATCH="PREVIOUSLY MATCHED/VALIDATED (RENEWAL)"
End DoDot:1
+5 IF '$TEST
Begin DoDot:1
+6 SET MATCH=$SELECT(AMATCH=1:"SUGGESTED",AMATCH=2:"SUGGESTED/EDITED",VADRGIEN:"MANUAL ENTRY",1:"")
+7 IF VALUSER'=""
IF MATCH'=""
SET MATCH=MATCH_" | VALIDATED by "_$EXTRACT(VALUSER,1,19)_" on "_$$FMTE^XLFDT(VALDTTM*10000\1/10000,"2Y")
+8 IF MATCH=""
SET MATCH="NOT MATCHED"
End DoDot:1
+9 SET MATCH="DRUG/SIG "_MATCH
IF $LENGTH(MATCH)>78
SET MATCH=$EXTRACT(MATCH,1,78)
+10 SET HDR=""
SET $EXTRACT(HDR,(80-$LENGTH(MATCH))\2+1)=MATCH
SET $EXTRACT(HDR,81)=""
+11 SET $EXTRACT(MATCH,81)=""
+12 SET UNDERLN(LINE,1)=100
IF HDR["/EDITED"
SET BLINKLN(LINE,$FIND(HDR,"/EDITED")-6)=6
+13 DO ADDLINE^PSOERUT0("LM",NMSPC,HDR,"")
+14 QUIT
+15 ;
ADDPNOTE(LINE,PNCOMM) ;
+1 NEW DUZTITLE
+2 SET LINE=LINE+1
SET @TMPGBL@(LINE,0)=""
+3 SET LINE=LINE+1
SET @TMPGBL@(LINE,0)=PNCOMM
+4 SET LINE=LINE+1
SET @TMPGBL@(LINE,0)=""
+5 SET LINE=LINE+1
SET @TMPGBL@(LINE,0)="Provider's feedback pending."
+6 SET LINE=LINE+1
SET @TMPGBL@(LINE,0)=""
+7 QUIT
+8 ;
CHECKREC(RECARY) ;check if there are any change requests made for this original eRx.
+1 ;Input : RECARY - A pass by reference variable name of the array that contain all eRx already been sent
+2 ;Output: SELCTREC - Selected option: N for New or R for Resend
+3 ; If R, it will be concatenated with the entry # to resend.
+4 NEW RECCNT,RECIEN,DDASH,ERXHUBID,ERXTYPE,ERXSTAT,ERXDTM,CNTR,RECENTRY
+5 IF $DATA(RECARY)
Begin DoDot:1
+6 WRITE !,"#",?5,"ERX ID",?21,"ERX TYPE",?40,"STATUS",?50,"DATE/TIME"
+7 SET $PIECE(DDASH,"-",81)=""
WRITE !,DDASH
+8 SET CNTR=0
+9 FOR
SET CNTR=$ORDER(RECARY(CNTR))
if 'CNTR
QUIT
Begin DoDot:2
+10 SET RECIEN=RECARY(CNTR)
+11 SET ERXHUBID=$PIECE($GET(^PS(52.49,RECIEN,0)),"^",1)
+12 SET ERXTYPE=$$GET1^DIQ(52.49,RECIEN,.08,"E")
+13 SET ERXSTAT=$$GET1^DIQ(52.49,RECIEN,1,"E")
+14 SET ERXDTM=$$GET1^DIQ(52.49,RECIEN,.03,"I")
SET ERXDTM=$$FMTE^XLFDT(ERXDTM,1)
+15 WRITE !,CNTR,?5,ERXHUBID,?21,ERXTYPE,?40,ERXSTAT,?50,ERXDTM
+16 SET RECCNT=CNTR
End DoDot:2
+17 SET SELCTREC=$$SELCTREC
+18 IF SELCTREC="R"
Begin DoDot:2
+19 KILL DIR
SET DIR(0)="LO^1:"_RECCNT
SET DIR("A")="Select Entry # to Resend"
+20 WRITE !
DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)
QUIT
+21 SET RECENTRY=+Y
End DoDot:2
End DoDot:1
+22 QUIT $GET(SELCTREC)_$SELECT($GET(SELCTREC)="R":$GET(RECENTRY),1:"")
+23 ;
SELCTREC() ;prompt user to select REC
+1 ; N - New
+2 ; R - Resend existing REC
+3 NEW PSOASK,PSODIRA,PSODIRB,PSODIRH,PSODIR0
+4 WRITE !
+5 SET PSODIRA="Select Suggestion Option: (N)EW (R)ESEND: "
+6 SET PSODIRB=""
+7 SET PSODIRH="^D HELP^PSOERX1H"
+8 SET PSODIR0="SOA^N:NEW;R:RESEND"
+9 SET PSOASK=$$ANSWER(PSODIRA,PSODIRB,PSODIR0,PSODIRH)
+10 QUIT $GET(PSOASK)
+11 ;
ANSWER(PSODIRA,PSODIRB,PSODIR0,PSODIRH) ;
+1 ; Input:
+2 ; PSODIR0 - DIR(0) string
+3 ; PSODIRA - DIR("A") string
+4 ; PSODIRB - DIR("B") string
+5 ; PSODIRH - DIR("?") string
+6 ; Output:
+7 ; Function Value - Internal value returned from ^DIR or -1 if user
+8 ; up-arrows, double up-arrows or the read times out.
+9 NEW X,Y,Z,DIR,DIROUT,DIRUT,DTOUT,DUOUT
+10 IF $DATA(PSODIR0)
SET DIR(0)=PSODIR0
+11 IF $DATA(PSODIRA)
SET DIR("A")=PSODIRA
+12 IF $GET(PSODIRB)]""
SET DIR("B")=PSODIRB
+13 IF $DATA(PSODIRH)
SET DIR("?")=PSODIRH
SET DIR("??")=PSODIRH
+14 DO ^DIR
+15 SET Z=$SELECT($DATA(DTOUT):-2,$DATA(DUOUT):-1,$DATA(DIROUT):-1,1:"")
+16 IF Z=""
SET Z=$SELECT(Y=-1:"",X="@":"@",1:$PIECE(Y,U))
QUIT Z
+17 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
QUIT -1
+18 QUIT $SELECT(X="@":"@",1:$PIECE(Y,U))
+19 ;
HELP ;REC help
+1 IF X="?"!(X="??")
Begin DoDot:1
+2 WRITE !!,"NEW - Adds a new Drug/SIG/Qty/Refills/Days Supply suggestion be sent to"
+3 WRITE " the prescriber as an alternative for this Change Request.",!
+4 WRITE !,"RESEND - Allow users to edit and resend an eRx Change Request."
End DoDot:1
+5 QUIT
+6 ;
BUILDSUM(ERXIEN) ;Build the existing record of the erx that the user selected
+1 ;Input - eRx IEN (Pointer to #52.49)
+2 ;Output - None
+3 NEW IENS,RSNTXT,X,RET,INDEX,CODE,Y
+4 KILL INDEX
SET CODE=0
+5 FOR
SET CODE=$ORDER(^PS(52.45,"TYPE","MRC",CODE))
if 'CODE
QUIT
SET INDEX($$GET1^DIQ(52.45,CODE,.01))=CODE
+6 SET REACODE=$$GET1^DIQ(52.49,ERXIEN,315.1,"I")
SET Y=$$GET1^DIQ(52.49,ERXIEN,315.1,"E")
+7 IF $GET(REACODE)'=+$GET(INDEX(Y))
SET REASCODE=0
SET EXTSCODE=""
KILL REATXT
+8 SET REACODE=+$GET(INDEX(Y))
SET EXTRCODE=$$GET1^DIQ(52.45,REACODE,.01)
+9 SET IENS=$ORDER(^PS(52.49,ERXIEN,316,0))
+10 IF IENS
Begin DoDot:1
+11 SET IENS=IENS_","_ERXIEN_","
+12 SET REASCODE=$$GET1^DIQ(52.49316,IENS,1,"I")
+13 SET EXTSCODE=$$GET1^DIQ(52.45,REASCODE,.01)
+14 SET EXTRCODE=$$GET1^DIQ(52.45,REACODE,.01)
End DoDot:1
+15 IF '$GET(IENS)
SET EXTSCODE=""
+16 SET RSNTXT=$$GET1^DIQ(52.49,ERXIEN,317,,"REATXT")
+17 IF $GET(REATXT(1))'=""
Begin DoDot:1
+18 SET X=REATXT(1)
KILL RET
DO TXT2ARY^PSOERXD1(.RET,X," ",80)
+19 KILL REATXT
MERGE REATXT=RET
End DoDot:1
+20 DO MEDREQ(ERXIEN)
+21 QUIT
+22 ;
MEDREQ(ERXIEN) ;Existing Medication Requested
+1 ;Input - eRx IEN (Pointer to #52.49)
+2 ;Output - CRMEDS array containing the medication requested
+3 NEW FILE,I,II,IENS,MEDREQ,DRUG,DRUGCODE,DRUGCODQ,SUBS,NOTE,QTYQUAL,QTY,NUMREFS,QUOM,CRMED,ERXSIG,X
+4 KILL ^TMP("PSOCRSIG",$JOB),CRMEDS
+5 SET II=0
+6 ;Only requested medications
FOR
SET II=$ORDER(^PS(52.49,ERXIEN,311,II))
if 'II
QUIT
Begin DoDot:1
+7 SET FILE=52.49311
SET IENS=II_","_ERXIEN_","
+8 KILL MEDREQ
DO GETS^DIQ(FILE,IENS,"**","IE","MEDREQ")
+9 IF $GET(MEDREQ(FILE,IENS,.02,"I"))="R"
Begin DoDot:2
+10 SET DRUG=$GET(MEDREQ(FILE,IENS,.03,"E"))
+11 SET DRUGTYPE=$SELECT($GET(MEDREQ(FILE,IENS,1.2,"E"))="ND":"V",1:"E")
+12 SET DRUGCODE=$GET(MEDREQ(FILE,IENS,1.1,"E"))
+13 SET DRUGCODQ=$GET(MEDREQ(FILE,IENS,1.2,"E"))
+14 SET SUBS=$GET(MEDREQ(FILE,IENS,2.7,"I"))
+15 SET NOTE=$GET(MEDREQ(FILE,IENS,5,"E"))
+16 SET QTYQUAL=$GET(MEDREQ(FILE,IENS,2.2,"E"))
+17 SET QTYUM=$GET(MEDREQ(FILE,IENS,2.3,"E"))
+18 SET QTY=$GET(MEDREQ(FILE,IENS,2.1,"E"))
+19 SET NUMREFS=$GET(MEDREQ(FILE,IENS,2.8,"E"))
+20 SET DAYSSUP=$GET(MEDREQ(FILE,IENS,2.4,"E"))
+21 SET QUOM=$GET(MEDREQ(FILE,IENS,2.3,"I"))
+22 SET QUOM=$$GET1^DIQ(52.45,QUOM,.02,"E")
+23 SET CRMED=$ORDER(CRMEDS(99),-1)+1
+24 SET CRMEDS(CRMED)=DRUGTYPE_"^"_DRUG_"^"_DRUGCODE_"^"_DRUGCODQ_"^"_SUBS_"^"_QTY_"^"_QTYQUAL_"^"_QTYUM_"^"_DAYSSUP_"^"_NUMREFS
+25 SET CRMEDS(CRMED,"NOTE")=NOTE
+26 SET X=$$GET1^DIQ(FILE,IENS,8,,"ERXSIG")
+27 FOR I=1:1
if '$DATA(ERXSIG(I))
QUIT
SET ^TMP("PSOCRSIG",$JOB,I,0)=ERXSIG(I)
+28 MERGE CRMEDS(CRMED,"SIG")=^TMP("PSOCRSIG",$JOB)
End DoDot:2
End DoDot:1
+29 QUIT
+30 ;
UNACC ; Un-Accept eRx from Pending Queue back into the Holding Queue
+1 NEW ORDNUM,ERXIEN,PSOIEN,DIE,DA,DR,DIC,PSOHOLD,PSOQUIT,DIR,X,Y,DTOUT,DUOUT,HOLDCOMM,POERR
+2 SET VALMBCK="R"
+3 IF '$GET(ORD)!'$DATA(^PS(52.41,+$GET(ORD),0))
SET VALMSG="Invalid Pending Order"
WRITE $CHAR(7)
QUIT
+4 IF " NW RNW "'[$$GET1^DIQ(52.41,ORD,2,"I")
SET VALMSG="eRx has already been finished or un-accepted."
WRITE $CHAR(7)
QUIT
+5 SET ORDNUM=$$GET1^DIQ(52.41,+ORD,.01)
IF 'ORDNUM
SET VALMSG="Invalid Pending Order"
WRITE $CHAR(7)
QUIT
+6 SET (ERXIEN,PSOIEN)=$$CHKERX^PSOERXU1(ORDNUM)
IF 'PSOIEN
SET VALMSG="This Pending Order is not related to an eRx"
WRITE $CHAR(7)
QUIT
+7 IF '$GET(ERXIEN)
SET VALMSG="This is not an eRx Prescription"
WRITE $CHAR(7)
QUIT
+8 DO FULL^VALM1
+9 ;
+10 KILL DIC
WRITE !
SET DIC("A")="Select HOLD reason code: "
+11 SET DIC="^PS(52.45,"
SET DIC(0)="AEMQ"
SET DIC("B")="HOLD FOR RX EDIT"
+12 SET DIC("S")="I $D(^PS(52.45,""TYPE"",""ERX"",Y)),$E($P(^PS(52.45,Y,0),U),1)=""H"""
+13 SET (PSOHOLD,PSOQUIT)=0
+14 FOR
DO ^DIC
Begin DoDot:1
+15 IF $GET(DUOUT)!$GET(DTOUT)
SET PSOQUIT=1
QUIT
+16 IF X=""
WRITE !,"HOLD Reason is required",!,$CHAR(7)
QUIT
+17 SET PSOHOLD=Y
End DoDot:1
IF PSOHOLD!PSOQUIT
QUIT
+18 IF $PIECE(PSOHOLD,"^",2)="HFF"
Begin DoDot:1
+19 WRITE !!,$GET(IOINHI),"The eRx will be un-held automatically on the date you enter below and placed"
+20 WRITE !,"in 'WAIT' status.",$GET(IOINORM)
+21 KILL DIR
WRITE !
SET DIR(0)="DA^"_$$FMADD^XLFDT(DT,1)_":"_$$FMADD^XLFDT($$GET1^DIQ(52.49,PSOIEN,5.9,"I"),$SELECT($$GET1^DIQ(52.49,PSOIEN,95.1,"I"):184,1:366))_":EX"
+22 IF $$EFFDATE^PSOERXU5(ERXIEN,1)'=""
SET DIR("B")=$$FMTE^XLFDT($$EFFDATE^PSOERXU5(ERXIEN,1))
+23 SET DIR("A")="Future Fill Hold Date: "
DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)
QUIT
+24 SET HFFDT=Y
End DoDot:1
IF $DATA(DIRUT)!$DATA(DIROUT)
QUIT
+25 IF PSOQUIT
QUIT
+26 ;
+27 KILL DIR,DA
SET DIR(0)="52.4919,1"
SET DIR("A")="Comments (Optional)"
+28 DO ^DIR
KILL DIR
IF Y="^"
QUIT
+29 SET HOLDCOMM=$GET(Y)
+30 ;
+31 KILL DIR
WRITE !
SET DIR("A",1)="This eRx will be Un-Accepted and sent back to the eRx Holding Queue."
+32 SET DIR("A",2)=""
SET DIR("A")="Confirm"
SET DIR(0)="Y"
SET DIR("B")="N"
+33 DO ^DIR
IF $GET(DIRUT)!$GET(DUOUT)!'Y
QUIT
+34 WRITE ?40,"Please wait..."
+35 ;
+36 ; Changing eRx Order Status to Hold
+37 DO UPDSTAT^PSOERXU1(ERXIEN,$PIECE(PSOHOLD,"^",2),HOLDCOMM,1,,$GET(HFFDT))
+38 ; Removing pointer to the Pending Order entry
+39 IF $PIECE($GET(^PS(52.49,ERXIEN,25)),"^",2)
SET $PIECE(^PS(52.49,ERXIEN,25),"^",2)=""
+40 ;
+41 if '$DATA(^PS(52.41,ORD,0))
QUIT
+42 KILL ^PS(52.41,"AOR",$PIECE(^PS(52.41,ORD,0),"^",2),+$PIECE($GET(^PS(52.41,ORD,"INI")),"^"),ORD)
+43 KILL ^PS(52.41,"AD",$PIECE(^PS(52.41,ORD,0),"^",12),+$PIECE($GET(^PS(52.41,ORD,"INI")),"^"),ORD)
+44 SET $PIECE(^PS(52.41,ORD,0),"^",3)="DC"
SET POERR("PLACER")=$PIECE(^(0),"^")
SET POERR("STAT")="OC"
+45 SET POERR("COMM")="eRx Un-Accepted: "_$$GET1^DIQ(52.45,+PSOHOLD,.02)_$SELECT(HOLDCOMM'="":" - "_HOLDCOMM,1:"")
+46 SET $PIECE(^PS(52.41,ORD,4),"^")=POERR("COMM")
+47 DO EN^PSOHLSN(POERR("PLACER"),POERR("STAT"),POERR("COMM"),"W")
+48 ;
+49 WRITE !!,"eRx successfully un-accepted and placed back on the eRx Holding Queue."
+50 KILL DIR
DO PAUSE^VALM1
+51 ;
+52 DO JUMP2ERX^PSOERX1I
KILL VALMBCK
+53 QUIT
+54 ;
UNACCBEF(ERXIEN) ; Determines if the eRx has been Un-Accepted Before
+1 ; Input: (r)ERXIEN - Pointer to ERX HOLDING QUEUE (#52.49)
+2 ;Output: P1: 1 - eRx has been Un-Accepted Before | 0 - Never been Un-Accepted
+3 ; P2: Un-Accepted by (if P1 = 1)
+4 ; P3: Un-Accepted date/time (if P1 = 1)
+5 ; Example: 1^LASTNAME,FIRSTNAME^9/26/24@10:30
+6 NEW UNACCBEF,STSHST
+7 SET UNACCBEF=0
+8 SET STSHST=9999
FOR
SET STSHST=$ORDER(^PS(52.49,ERXIEN,19,STSHST),-1)
if 'STSHST
QUIT
Begin DoDot:1
+9 SET UNACCBEF=+$$GET1^DIQ(52.4919,STSHST_","_ERXIEN,.04,"I")
+10 IF UNACCBEF
SET $PIECE(UNACCBEF,"^",2,3)=$EXTRACT($$GET1^DIQ(52.4919,STSHST_","_ERXIEN,.03),1,16)_"^"_$$FMTE^XLFDT($$GET1^DIQ(52.4919,STSHST_","_ERXIEN,.01,"I"),"2Y")
End DoDot:1
IF UNACCBEF
QUIT
+11 QUIT UNACCBEF
+12 ;
ASKCONT ; display "Press <Enter> or '^' to exit" prompt
+1 NEW Z
+2 WRITE !,$$CJ^XLFSTR("Press <Enter> or '^' to exit.",1)
+3 READ Z:DTIME
+4 QUIT
