PSOERX1H ;ALB/MFR - eRx Utilities ;Aug 14, 2020@12:43:34
;;7.0;OUTPATIENT PHARMACY;**700,746**;DEC 1997;Build 106
;
;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
. . I TYPE="R" D Q:$G(SKIPRX)
. . . S RXSTAT=$$GET1^DIQ(52.49,REMOVERX,1,"E")
. . . 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) ;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
;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 !,"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")
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),!
D UPDATEPN(+$G(PSOTIUDA),PSOIEN,.CRMEDS)
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
;
UPDATEPN(PSOTIUDA,PSOIEN,CRMEDS) ;Update 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,TIUX,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(.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"
S TIUX(1701)=$S($L(SUBJECT)>80:$E(SUBJECT,1,61)_"...",1:SUBJECT)
D UPDATE^TIUSRVP(.ERXRET,PSOTIUDA,.TIUX)
Q
;
DRUGHDR ;
; - Drug Matching Header Line
I $G(SDERXFLG) D ;SDERXFLG is set in the PSOERSE1 routine
. 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:"AUTO-MATCHED",AMATCH=2:"AUTO-MATCHED/EDITED",VADRGIEN:"MANUALLY-MATCHED",1:"")
. . I VALUSER'="",MATCH'="" S MATCH=MATCH_" | VALIDATED by "_$E(VALUSER,1,19)_" on "_$$FMTE^XLFDT(VALDTTM,"2Y")
. . I MATCH="" S MATCH="NOT MATCHED"
. S MATCH="DRUG "_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
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,5.2,"E"))
. . S QTYUM=$G(MEDREQ(FILE,IENS,5.4,"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
;
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 12306 printed Oct 16, 2024@18:28:57 Page 2
PSOERX1H ;ALB/MFR - eRx Utilities ;Aug 14, 2020@12:43:34
+1 ;;7.0;OUTPATIENT PHARMACY;**700,746**;DEC 1997;Build 106
+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 IF TYPE="R"
Begin DoDot:3
+17 SET RXSTAT=$$GET1^DIQ(52.49,REMOVERX,1,"E")
+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) ;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 ;Output: Update existing TIU Document for the Patient
+9 NEW TARGET,PSODFN,PSOPTNM,PSOTITL,PSOTIUDA,CRFDA
+10 ;
+11 IF $GET(PSOIEN)=""!($GET(CRERXIEN)="")!($GET(TIUTITLE)="")
QUIT
+12 if ",CX,CR,"'[(","_$PIECE($$ERXMTYPE^PSOERSE1(CRERXIEN),"^")_",")
QUIT
+13 SET TARGET=$NAME(^TMP("TIUP",$JOB))
KILL @TARGET
+14 IF $$GET1^DIQ(52.49,CRERXIEN,.08,"I")="CR"
WRITE !,"Creating a new Progress Note..."
+15 DO BUILDLST^PSOERSE4(TARGET,CRERXIEN,$GET(PNCOMM))
+16 SET PSOTITL=$$FIND1^DIC(8925.1,"","X",TIUTITLE,"B")
+17 ;IF NO TITLE ON SYSTEM
if '+PSOTITL
QUIT
+18 SET PSODFN=$$GET1^DIQ(52.49,PSOIEN,.05,"I")
+19 SET PSOPTNM=$PIECE($GET(^DPT(PSODFN,0)),U,1)
+20 DO NEW^TIUPNAPI(.PSOTIUDA,PSODFN,DUZ,$$NOW^XLFDT,PSOTITL,$GET(PSOCLNC))
+21 IF +$GET(PSOTIUDA)<0
Begin DoDot:1
+22 IF $$GET1^DIQ(52.49,CRERXIEN,.08,"I")="CR"
WRITE !,$GET(IOINHI),"A problem was encountered while creating the Progress Note.",$GET(IOINORM),!
End DoDot:1
QUIT
+23 DO UPDATEPN(+$GET(PSOTIUDA),PSOIEN,.CRMEDS)
+24 ;parent TIU IEN reference number for eRx Change Request
SET CRFDA(52.49,CRERXIEN_",",320.1)=+$GET(PSOTIUDA)
+25 ;VA Pharmacy Progress Notes
IF $GET(PNCOMM)'=""
SET CRFDA(52.49,CRERXIEN_",",320.2)=$GET(PNCOMM)
+26 DO FILE^DIE(,"CRFDA")
KILL CRFDA
+27 IF $$GET1^DIQ(52.49,CRERXIEN,.08,"I")="CR"
WRITE "Done."
HANG .5
+28 QUIT
+29 ;
UPDATEPN(PSOTIUDA,PSOIEN,CRMEDS) ;Update 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,TIUX,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(.05)=$$FIND1^DIC(8925.6,"","X","COMPLETED","B")
+21 SET TIUX(1501)=$$NOW^XLFDT()
+22 SET TIUX(1502)=DUZ
+23 SET TIUX(1503)=$$GET1^DIQ(200,+DUZ,20.2)
+24 SET TIUX(1504)=$$GET1^DIQ(200,+DUZ,20.3)
+25 SET TIUX(1505)="E"
+26 SET TIUX(1701)=$SELECT($LENGTH(SUBJECT)>80:$EXTRACT(SUBJECT,1,61)_"...",1:SUBJECT)
+27 DO UPDATE^TIUSRVP(.ERXRET,PSOTIUDA,.TIUX)
+28 QUIT
+29 ;
DRUGHDR ;
+1 ; - Drug Matching Header Line
+2 ;SDERXFLG is set in the PSOERSE1 routine
IF $GET(SDERXFLG)
Begin DoDot:1
+3 SET AMATCH=$$GET1^DIQ(52.49,ERXIEN,1.4,"I")
+4 SET VALUSER=$$GET1^DIQ(52.49,ERXIEN,1.11,"E")
SET VALDTTM=$$GET1^DIQ(52.49,ERXIEN,1.12,"I")
+5 IF $$GET1^DIQ(52.49,ERXIEN,.08,"I")="RE"
IF 'VALDTTM
Begin DoDot:2
+6 SET MATCH="PREVIOUSLY MATCHED/VALIDATED (RENEWAL)"
End DoDot:2
+7 IF '$TEST
Begin DoDot:2
+8 SET MATCH=$SELECT(AMATCH=1:"AUTO-MATCHED",AMATCH=2:"AUTO-MATCHED/EDITED",VADRGIEN:"MANUALLY-MATCHED",1:"")
+9 IF VALUSER'=""
IF MATCH'=""
SET MATCH=MATCH_" | VALIDATED by "_$EXTRACT(VALUSER,1,19)_" on "_$$FMTE^XLFDT(VALDTTM,"2Y")
+10 IF MATCH=""
SET MATCH="NOT MATCHED"
End DoDot:2
+11 SET MATCH="DRUG "_MATCH
IF $LENGTH(MATCH)>78
SET MATCH=$EXTRACT(MATCH,1,78)
+12 SET HDR=""
SET $EXTRACT(HDR,(80-$LENGTH(MATCH))\2+1)=MATCH
SET $EXTRACT(HDR,81)=""
+13 SET $EXTRACT(MATCH,81)=""
+14 SET UNDERLN(LINE,1)=100
IF HDR["/EDITED"
SET BLINKLN(LINE,$FIND(HDR,"/EDITED")-6)=6
+15 DO ADDLINE^PSOERUT0("LM",NMSPC,HDR,"")
End DoDot:1
+16 QUIT
+17 ;
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
+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,5.2,"E"))
+17 SET QTYUM=$GET(MEDREQ(FILE,IENS,5.4,"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 ;
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
