PSOERSE1 ;ALB/RM - Single eRx View/Display ;Jan 30, 2024@12:43:34
;;7.0;OUTPATIENT PHARMACY;**746,769**;DEC 16, 1997;Build 26
;
;
Q ;No Direct Call
;
EN(PSOIEN) ; -- main entry point for PSO ERX SINGLE ERX DISPLAY
N ERXIEN,MBMSITE,ERXSTATSD,ERXMTYPE,SDERXFLG,HGHLIGHT
Q:'$G(PSOIEN)
S ERXIEN=PSOIEN
S ERXSTATSD="" ;this variable is used to hold the eRx status
S SDERXFLG=1
S MBMSITE=$S($$GET1^DIQ(59.7,1,102,"I")="MBM":1,1:0)
D EN^VALM("PSO ERX SINGLE ERX DISPLAY")
Q
;
HDR ; -- header code
N HDR K VALMHDR
S VALMHDR(1)="eRx Patient: "_IOINHI_$E($$GET1^DIQ(52.49,ERXIEN,.04,"E"),1,30)_IOINORM
D INSTR^VALM1("eRx Reference #: "_IOINHI_$$GET1^DIQ(52.49,ERXIEN,.01)_IOINORM,50,2)
S VALMHDR(2)="eRx Msg Type: "_IOINHI_$$GETMTYPE(ERXIEN)_IOINORM
I $$GET1^DIQ(52.49,ERXIEN,10.5,"I")=2 D
. D INSTR^VALM1(IORVON_"ERX HAS DO NOT FILL INDICATOR PER PROVIDER"_IORVOFF,39,3)
E I $$GET1^DIQ(52.49,ERXIEN,95.1,"I") D
. D INSTR^VALM1(IORVON_"EPCS DEA VALIDATED"_IORVOFF,63,3) ;controlled substance indicator
E D INSTR^VALM1("Written: "_IOINHI_$$FMTE^XLFDT($$GET1^DIQ(52.49,ERXIEN,5.9,"I")\1,"2Z"),64,3)
S VALMHDR(3)=IORVOFF_"eRx Status: "_IOINHI_$$GET1^DIQ(52.49,ERXIEN,1)_" - "_$$GET1^DIQ(52.45,$$GET1^DIQ(52.49,ERXIEN,1,"I"),.02)
S VALMHDR(3)=VALMHDR(3)_$S($$GET1^DIQ(52.49,ERXIEN,1)="HFF":" ("_$$GET1^DIQ(52.49,ERXIEN,6.7)_")",1:"")_IOINORM
I ",RR,RE,IE,OE,CA,CN,CX,CR,"'[(","_$$GET1^DIQ(52.49,ERXIEN,.08,"I")_",") D
. S HDR="",$E(HDR,20)="ERX",$E(HDR,40)="|",$E(HDR,58)="VISTA"
S $E(HDR,81)="" D INSTR^VALM1(IORVON_IOUON_HDR_IORVOFF_IOINORM,1,5)
Q
;
GETMTYPE(ERXIEN) ;Retrieve the eRx Message Type
; Input : ERXIEN - Pointer to ERX HOLDING QUEUE file (#52.49)
; Output: MTYPEE - eRx Message Type
N MTYPE,MTYPEE,RESPVAL,CHGMESRQ,CHGMESRI
S MTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
S MTYPEE=$$GET1^DIQ(52.49,ERXIEN,.08,"E")
S RESPVAL=$$GET1^DIQ(52.49,ERXIEN,52.1,"E")
S CHGMESRQ=$$GET1^DIQ(52.49,ERXIEN,315.1,"I")
S CHGMESRI=$$GET1^DIQ(52.45,CHGMESRQ,.01,"I")
I (",RE,CN,"[(","_MTYPE_","))!((MTYPE="CX")&$$CHGMTYPE^PSOERX1D(ERXIEN,MTYPE,RESPVAL,CHGMESRI)) S MTYPEE=$G(MTYPEE)_"-"_$$GET1^DIQ(52.49,ERXIEN,52.1,"E")
;I $$GET1^DIQ(52.49,ERXIEN,95.1,"I") S $E(MTYPEE,63)="EPCS DEA VALIDATED" ;controlled substance indicator - commenting this because this will be overwritten with the Written date
Q $G(MTYPEE)
;
INIT ;
N DDASH,MODE,NMSPC,ERXDATA,EPRVIEN,ERXDRGID,S2017,ERXRDT,XE,ERXHLDARY,ERXHLD,ERXHLDRSN
;determine the message type of this transaction to decide whether to display the side-by-side format or retain it as is.
S ERXMTYPE=$P($$ERXMTYPE(ERXIEN),"^")
S NMSPC="PSOERSE1",MODE="LM"
K ^TMP("PSOERSE1",$J)
S LINE=0
D RESET^PSOERUT0() ; - Resetting list to NORMAL video attributes
S ^TMP("PSOERSE1",$J,1,0)=""
S VALMBG=1
;
;display and set the hold reason if the eRx has a hold status and if it contains data, otherwise, do not display
S ERXHLD=$$GETHLDSTA(.ERXHLDARY,ERXIEN)
I +$G(ERXHLD)>1,$G(ERXHLDARY($J,3))'="" D
. S ERXHLDRSN=$G(ERXHLDARY($J,3))
. I $L(ERXHLDARY($J,3))>62 S ERXHLDRSN=$E(ERXHLDARY($J,3),1,60)_"..." ;truncate if it is longer than 60
. S LINE=LINE+1 D ADDLINE^PSOERUT0(MODE,NMSPC,"eRx Hold Reason: "_ERXHLDRSN) ;this API automatically add a line, so no need to increment the line number
. D CNTRL^VALM10(LINE-1,18,$L(ERXHLDRSN),IOINHI,IOINORM)
;
I ",RR,RE,IE,OE,CA,CN,CX,CR,"[(","_ERXMTYPE_",") D Q ;if the message type contain one these types, the display will remain as is (NOT side by side format)
. S SDERXFLG=0 D INIT^PSOERSE2(ERXIEN,SDERXFLG)
. I $D(@VALMAR) D
. . I $D(@VALMAR@(LINE)) S LINE=LINE+1
. . S $P(DDASH,"_",81)="" D SET^VALM10(LINE,DDASH)
. . S LINE=LINE+1 D ERXRCVDT(ERXIEN)
. . I '$D(@VALMAR@(LINE)) S LINE=LINE-1 D CNTRL^VALM10(LINE,1,80,IOINHI,IOINORM)
. . S VALMCNT=LINE
;
;side by side format begins here
D SETPAT^PSOERUT0(MODE,ERXIEN,,NMSPC,0,1) ;Display Patient data
S EPRVIEN=$$GET1^DIQ(52.49,ERXIEN,2.1,"I")
I 'EPRVIEN S EPRVIEN=$$GETPROV^PSOERXU5(ERXIEN)
D SETPROV^PSOERUT1(MODE,ERXIEN,,NMSPC,0,1) ;Display Provider data
;
D ERXDATA^PSOERXU9(.ERXDATA,ERXIEN)
S ERXDRGID=""
I $D(ERXDATA) S ERXDRGID=$P(ERXDATA(1),"^",4)
D SETDRUG^PSOERUT2(MODE,NMSPC,ERXIEN,0,0,1) ;Display Drug Data
;
S S2017=$$GET1^DIQ(52.49,PSOIEN,312.1,"I") ;display erx written and issue/effective date
D S2017(MODE,NMSPC,ERXIEN,S2017)
D ALLERGY^PSOERUT3(MODE,NMSPC,ERXIEN,+$$GET1^DIQ(52.49,ERXIEN,.05,"I"))
D SETDIAGS^PSOERUT3(MODE,NMSPC,ERXIEN)
;
D ERXRCVDT(ERXIEN) ;display the eRx Received Date time stamp
; DEA Note for CS Digitally Signed eRx records
I $$GET1^DIQ(52.49,PSOIEN,95.1,"I") S LINE=LINE-1 D DEANOTE(.LINE)
S VALMCNT=LINE-1
D VIDEO^PSOERUT0() ; Changes the Video Attributes for the list
;
HELP ; -- help code
;S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ERXSTATSD
D CLEAN^VALM10
D CLEAR^VALM1
S VALMBCK="R",PSOREFSH=1
Q
;
EXPND ; -- expand code
Q
;
ERXMTYPE(ERXIEN) ;Retrieve the message type in File 52.49
; Input: ERXIEN - Pointer to ERX HOLDING QUEUE file (#52.49)
;Output: Message Type Internal Value^Message Type External Value
I +$G(ERXIEN)<1 Q ""
N ERXMTYPE,ERTYPEX,STATIEN,ERXSTAT
S ERXMTYPE=""
S ERXMTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
S ERTYPEX=$$GET1^DIQ(52.49,ERXIEN,.08,"E")
S STATIEN=$$GET1^DIQ(52.49,ERXIEN,1,"I")
S ERXSTAT=$$GET1^DIQ(52.45,STATIEN,.02,"E")
Q $G(ERXMTYPE)_"^"_$G(ERTYPEX)
;
ERXRCVDT(ERXIEN) ;
N ERXRDT
S ERXRDT=$$GETERXRDT(ERXIEN) ;display the eRx Received Date time stamp
I $G(ERXRDT)'="" D
. S XE=" eRx Received on "_$P(ERXRDT,"^")
. I $P(ERXRDT,"^",2)'="" S XE=XE_" - Accepted by "_$P(ERXRDT,"^",2)_" on "_$P(ERXRDT,"^",3)
. E S XE=" "_XE
. D ADDLINE^PSOERUT0(MODE,NMSPC,$$COMPARE^PSOERUT0("LM",XE,XE,2))
Q
;
S2017(MODE,NAMESPACE,ERXIEN,S2017) ;Retrieve erx written and effective/issue date
N ERXWDATE,ERXEFFDT,WDATE,ERXDT,XE,XV,MIEN,X
I 'S2017 D
. S WDATE=$$GET1^DIQ(52.49,ERXIEN,5.9,"I")\1
. S ERXDT=$$GET1^DIQ(52.49,ERXIEN,.03,"I")
. S XE="Written: "_$$COMPARE^PSOERUT0(MODE,$$FMTE^XLFDT(WDATE,"2Z"),$$FMTE^XLFDT(WDATE,"2Z"),10)
. S XE=XE_" Effective: "_$$COMPARE^PSOERUT0(MODE,$$FMTE^XLFDT($P(ERXDT,"."),"2Z"),$$FMTE^XLFDT($P(ERXDT,"."),"2Z"),31)
. D ADDLINE^PSOERUT0(MODE,NMSPC,XE,"|")
I S2017 D
. S MIEN=$O(^PS(52.49,ERXIEN,311,0))
. S ERXEFFDT="",X=$$EFFDATE^PSOERXU5(ERXIEN,MIEN) I X'="" D ^%DT S ERXEFFDT=Y
. S ERXWDATE=$$GET1^DIQ(52.49,ERXIEN,5.9,"I")\1
. S XE="Written: "_$$COMPARE^PSOERUT0(MODE,$$FMTE^XLFDT($P(ERXWDATE,"."),"2Z"),$$FMTE^XLFDT($P(ERXWDATE,"."),"2Z"),10)
. S XE=XE_" Effective: "_$$COMPARE^PSOERUT0(MODE,$$FMTE^XLFDT(ERXEFFDT,"2Z"),$$FMTE^XLFDT(ERXEFFDT,"2Z"),31)
. D ADDLINE^PSOERUT0(MODE,NMSPC,XE,"|")
Q
;
GETHLDSTA(ERXHLDARY,ERXIEN) ;Retrieve the Erx Hold Status, Reason, and Hold By
; Input : ERXIEN - Pointer to ERX HOLDING QUEUE file (#52.49)
; Output: ERXHLDARY - An array which must be passed in by reference; returned with the following:
; ERXHLDARY(#)=value or if no hold status ERXHLDARY(0)=""
; Where:
; # - is a sequential number greater than zero
; value - is a line of text
; 1-Hold Status
; 2-Hold Reason
; 3-Hold Entered By
N CURSTATE,CURSTATI,CNTR,HARY,HL,LHMATCH,LHFOUND,LHSTATI
K ERXHLDARY
; only set the hold reason if the eRx has a hold status and hold reason contains data
S CURSTATE=$$GET1^DIQ(52.49,ERXIEN,1,"E")
S (VAHSTA,VAHREA,VAHPER)=""
S CNTR=0
I $E(CURSTATE,1)="H" D
. S CURSTATI=$$GET1^DIQ(52.49,ERXIEN,1,"I")
. S LHMATCH=999999,LHFOUND=0 F S LHMATCH=$O(^PS(52.49,ERXIEN,19,LHMATCH),-1) Q:'LHMATCH!(LHFOUND) D
. . S LHSTATI=$$GET1^DIQ(52.4919,LHMATCH_","_ERXIEN_",",.02,"I") I LHSTATI=CURSTATI D S LHFOUND=LHMATCH Q
. . . S VAHSTA=$$GET1^DIQ(52.45,LHSTATI,.01,"E")_" - "_$$GET1^DIQ(52.45,LHSTATI,.02,"E"),CNTR=CNTR+1,ERXHLDARY($J,CNTR)=VAHSTA
. . . S VAHPER=$$GET1^DIQ(52.4919,LHMATCH_","_ERXIEN_",",.03,"E"),CNTR=CNTR+1,ERXHLDARY($J,CNTR)=VAHPER
. . . S VAHREA=$$GET1^DIQ(52.4919,LHMATCH_","_ERXIEN_",",1),CNTR=CNTR+1,ERXHLDARY($J,CNTR)=VAHREA
I CNTR<1 S ERXHLDARY($J,0)=""
Q $G(CNTR)
;
GETERXRDT(ERXIEN) ;Retrieve the eRx Received Date time stamp
; Input : ERXIEN - Pointer to ERX HOLDING QUEUE file (#52.49)
; Output: ERXRADT - eRx Recieved Date time stamp^accepted by^date accepted
; Example: 1/19/24@14:05^LASTNAME,FIRSTNAME^9/26/24@10:30
N ACCDTBY,ERXRADT
Q:'$G(ERXIEN)
S ACCDTBY=$$ACCDTBY^PSOERUT4(ERXIEN)
S ERXRADT=$P($$FMTE^XLFDT($$GET1^DIQ(52.49,ERXIEN,.03,"I"),"2Y"),":",1,2)
S ERXRADT=ERXRADT_"^"_$E($P(ACCDTBY,"^",2),1,17)_"^"_$P($P(ACCDTBY,"^",1),":",1,2)
Q $G(ERXRADT)
;
REF ;Screen Refresh
I $D(VALMEVL) F I=1:1:99 D RESTORE^VALM10(I)
D HDR,INIT S VALMBCK="R"
Q
;
VO ; View Original eRx Action
N ORERXIEN,ERX
S ORERXIEN=$$RELERX(ERXIEN,"N")
I ORERXIEN S (ERXIEN,PSOIEN)=ORERXIEN
E I ORERXIEN=0 S VALMSG="No Original eRx Found" S VALMBCK="R" W $C(7) Q
D REF
Q
;
VRR ; View Request
N RRERXIEN,ERX
S RRERXIEN=$$RELERX(ERXIEN,"RR,CR,CA")
I RRERXIEN S (ERXIEN,PSOIEN)=RRERXIEN
E I RRERXIEN=0 S VALMSG="No Request eRx Found" S VALMBCK="R" W $C(7) Q
D REF
Q
;
VRE ; View Request Response
N REERXIEN,ERX
S REERXIEN=$$RELERX(ERXIEN,"RE,CN,CX")
I REERXIEN S (ERXIEN,PSOIEN)=REERXIEN
E I REERXIEN=0 S VALMSG="No Response eRx Found" S VALMBCK="R" W $C(7) Q
D REF
Q
;
RELERX(ERXIEN,MSGTYPE) ; Returns the Selected Related eRx IEN
; Input: ERXIEN - Pointer to ERX HOLDING QUEUE (#52.49)
; MSGTYPE - Relation types ("N":NewRx;"RR,CR,CA":Request;"RE,CN,CX":Response)
;Output: RELERX - Selected Related eRx (Original, Response, Request) - Pointer to #52.49 (0 if not found)
N ERX,ERXARR,TMPARR,X,Y,DTOUT,DIROUT,SEQ,DIR,XX,RERX,REQIEN,RESIEN,ORIGIEN,MTYPE
S (SEQ,ERX)=0
F S ERX=$O(^PS(52.49,ERXIEN,201,"B",ERX)) Q:'ERX D
. I '$D(TMPARR(ERX)),","_MSGTYPE_","[(","_$$GET1^DIQ(52.49,ERX,.08,"I")_",") D
. . S SEQ=SEQ+1,ERXARR(SEQ)=ERX,TMPARR(ERX)=""
. E S RERX=0 F S RERX=$O(^PS(52.49,ERX,201,"B",RERX)) Q:'RERX D
. . I '$D(TMPARR(RERX)),","_MSGTYPE_","[(","_$$GET1^DIQ(52.49,RERX,.08,"I")_",") D
. . . S SEQ=SEQ+1,ERXARR(SEQ)=RERX,TMPARR(RERX)=""
;
I '$D(ERXARR) D
. S MTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
. S (ORIGIEN,REQIEN,RESIEN)=0
. I ",RR,CA,CR,"[(","_MTYPE_",") D
. . S REQIEN=ERXIEN,RESIEN=$$GETRESP^PSOERXU2(ERXIEN)
. I ",RE,CN,CX,"[(","_MTYPE_",") D
. . S RESIEN=ERXIEN,REQIEN=$$RESOLV^PSOERXU2(ERXIEN)
. I MTYPE="IE" D
. . S RESIEN=ERXIEN,REQIEN=$$RESOLV^PSOERXU2(ERXIEN)
. I $G(REQIEN) D
. . S ORIGIEN=+$O(^PS(52.49,"B",+$$GET1^DIQ(52.49,REQIEN,.14),0))
. I MSGTYPE="N",$G(ORIGIEN),ORIGIEN'=ERXIEN S SEQ=SEQ+1,ERXARR(SEQ)=ORIGIEN
. I MSGTYPE="RR,CR,CA",$G(REQIEN) S SEQ=SEQ+1,ERXARR(SEQ)=REQIEN
. I MSGTYPE="RE,CN,CX",$G(RESIEN) S SEQ=SEQ+1,ERXARR(SEQ)=RESIEN
;
I '$D(ERXARR) Q 0
I '$D(ERXARR(2)) Q $G(ERXARR(1))
D FULL^VALM1
W !!,"# ERX ID",?22,"ERX TYPE",?42,"STATUS",?50,"DATE/TIME"
S XX="",$P(XX,"-",72)="" W !,XX
S SEQ=0 F S SEQ=$O(ERXARR(SEQ)) Q:'SEQ D
. S ERX=ERXARR(SEQ) W !,SEQ,?3,$$GET1^DIQ(52.49,ERX,.01),?22,$$GET1^DIQ(52.49,ERX,.08),?42,$$GET1^DIQ(52.49,ERX,1),?50,$$GET1^DIQ(52.49,ERX,.03)
W ! S DIR(0)="L^1:"_$O(ERXARR(999),-1),DIR("A")="SELECT"
D ^DIR I $D(DIRUT)!$D(DIROUT) Q "^"
Q ERXARR(+Y)
Q
;
DEANOTE(LINE) ;DEA Note for CS Digitally Signed eRx records
N LINETXT
S LINE=LINE+1 D SET^VALM10(LINE,"")
S LINE=LINE+1,LINETXT=" This prescription meets the requirements of the Drug Enforcement Administration"
D SET^VALM10(LINE,LINETXT),CNTRL^VALM10(LINE,1,$L(LINETXT)+1,IOINHI,IOINORM)
S LINE=LINE+1,LINETXT=" (DEA) electronic prescribing for controlled substances rules (21 CFR Parts 1300,"
D SET^VALM10(LINE,LINETXT),CNTRL^VALM10(LINE,1,$L(LINETXT)+1,IOINHI,IOINORM)
S LINE=LINE+1,LINETXT=" 1304, 1306, & 1311)."
D SET^VALM10(LINE,LINETXT),CNTRL^VALM10(LINE,2,$L(LINETXT),IOINHI,IOINORM)
S LINE=LINE+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOERSE1 12234 printed Dec 13, 2024@02:27:55 Page 2
PSOERSE1 ;ALB/RM - Single eRx View/Display ;Jan 30, 2024@12:43:34
+1 ;;7.0;OUTPATIENT PHARMACY;**746,769**;DEC 16, 1997;Build 26
+2 ;
+3 ;
+4 ;No Direct Call
QUIT
+5 ;
EN(PSOIEN) ; -- main entry point for PSO ERX SINGLE ERX DISPLAY
+1 NEW ERXIEN,MBMSITE,ERXSTATSD,ERXMTYPE,SDERXFLG,HGHLIGHT
+2 if '$GET(PSOIEN)
QUIT
+3 SET ERXIEN=PSOIEN
+4 ;this variable is used to hold the eRx status
SET ERXSTATSD=""
+5 SET SDERXFLG=1
+6 SET MBMSITE=$SELECT($$GET1^DIQ(59.7,1,102,"I")="MBM":1,1:0)
+7 DO EN^VALM("PSO ERX SINGLE ERX DISPLAY")
+8 QUIT
+9 ;
HDR ; -- header code
+1 NEW HDR
KILL VALMHDR
+2 SET VALMHDR(1)="eRx Patient: "_IOINHI_$EXTRACT($$GET1^DIQ(52.49,ERXIEN,.04,"E"),1,30)_IOINORM
+3 DO INSTR^VALM1("eRx Reference #: "_IOINHI_$$GET1^DIQ(52.49,ERXIEN,.01)_IOINORM,50,2)
+4 SET VALMHDR(2)="eRx Msg Type: "_IOINHI_$$GETMTYPE(ERXIEN)_IOINORM
+5 IF $$GET1^DIQ(52.49,ERXIEN,10.5,"I")=2
Begin DoDot:1
+6 DO INSTR^VALM1(IORVON_"ERX HAS DO NOT FILL INDICATOR PER PROVIDER"_IORVOFF,39,3)
End DoDot:1
+7 IF '$TEST
IF $$GET1^DIQ(52.49,ERXIEN,95.1,"I")
Begin DoDot:1
+8 ;controlled substance indicator
DO INSTR^VALM1(IORVON_"EPCS DEA VALIDATED"_IORVOFF,63,3)
End DoDot:1
+9 IF '$TEST
DO INSTR^VALM1("Written: "_IOINHI_$$FMTE^XLFDT($$GET1^DIQ(52.49,ERXIEN,5.9,"I")\1,"2Z"),64,3)
+10 SET VALMHDR(3)=IORVOFF_"eRx Status: "_IOINHI_$$GET1^DIQ(52.49,ERXIEN,1)_" - "_$$GET1^DIQ(52.45,$$GET1^DIQ(52.49,ERXIEN,1,"I"),.02)
+11 SET VALMHDR(3)=VALMHDR(3)_$SELECT($$GET1^DIQ(52.49,ERXIEN,1)="HFF":" ("_$$GET1^DIQ(52.49,ERXIEN,6.7)_")",1:"")_IOINORM
+12 IF ",RR,RE,IE,OE,CA,CN,CX,CR,"'[(","_$$GET1^DIQ(52.49,ERXIEN,.08,"I")_",")
Begin DoDot:1
+13 SET HDR=""
SET $EXTRACT(HDR,20)="ERX"
SET $EXTRACT(HDR,40)="|"
SET $EXTRACT(HDR,58)="VISTA"
End DoDot:1
+14 SET $EXTRACT(HDR,81)=""
DO INSTR^VALM1(IORVON_IOUON_HDR_IORVOFF_IOINORM,1,5)
+15 QUIT
+16 ;
GETMTYPE(ERXIEN) ;Retrieve the eRx Message Type
+1 ; Input : ERXIEN - Pointer to ERX HOLDING QUEUE file (#52.49)
+2 ; Output: MTYPEE - eRx Message Type
+3 NEW MTYPE,MTYPEE,RESPVAL,CHGMESRQ,CHGMESRI
+4 SET MTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
+5 SET MTYPEE=$$GET1^DIQ(52.49,ERXIEN,.08,"E")
+6 SET RESPVAL=$$GET1^DIQ(52.49,ERXIEN,52.1,"E")
+7 SET CHGMESRQ=$$GET1^DIQ(52.49,ERXIEN,315.1,"I")
+8 SET CHGMESRI=$$GET1^DIQ(52.45,CHGMESRQ,.01,"I")
+9 IF (",RE,CN,"[(","_MTYPE_","))!((MTYPE="CX")&$$CHGMTYPE^PSOERX1D(ERXIEN,MTYPE,RESPVAL,CHGMESRI))
SET MTYPEE=$GET(MTYPEE)_"-"_$$GET1^DIQ(52.49,ERXIEN,52.1,"E")
+10 ;I $$GET1^DIQ(52.49,ERXIEN,95.1,"I") S $E(MTYPEE,63)="EPCS DEA VALIDATED" ;controlled substance indicator - commenting this because this will be overwritten with the Written date
+11 QUIT $GET(MTYPEE)
+12 ;
INIT ;
+1 NEW DDASH,MODE,NMSPC,ERXDATA,EPRVIEN,ERXDRGID,S2017,ERXRDT,XE,ERXHLDARY,ERXHLD,ERXHLDRSN
+2 ;determine the message type of this transaction to decide whether to display the side-by-side format or retain it as is.
+3 SET ERXMTYPE=$PIECE($$ERXMTYPE(ERXIEN),"^")
+4 SET NMSPC="PSOERSE1"
SET MODE="LM"
+5 KILL ^TMP("PSOERSE1",$JOB)
+6 SET LINE=0
+7 ; - Resetting list to NORMAL video attributes
DO RESET^PSOERUT0()
+8 SET ^TMP("PSOERSE1",$JOB,1,0)=""
+9 SET VALMBG=1
+10 ;
+11 ;display and set the hold reason if the eRx has a hold status and if it contains data, otherwise, do not display
+12 SET ERXHLD=$$GETHLDSTA(.ERXHLDARY,ERXIEN)
+13 IF +$GET(ERXHLD)>1
IF $GET(ERXHLDARY($JOB,3))'=""
Begin DoDot:1
+14 SET ERXHLDRSN=$GET(ERXHLDARY($JOB,3))
+15 ;truncate if it is longer than 60
IF $LENGTH(ERXHLDARY($JOB,3))>62
SET ERXHLDRSN=$EXTRACT(ERXHLDARY($JOB,3),1,60)_"..."
+16 ;this API automatically add a line, so no need to increment the line number
SET LINE=LINE+1
DO ADDLINE^PSOERUT0(MODE,NMSPC,"eRx Hold Reason: "_ERXHLDRSN)
+17 DO CNTRL^VALM10(LINE-1,18,$LENGTH(ERXHLDRSN),IOINHI,IOINORM)
End DoDot:1
+18 ;
+19 ;if the message type contain one these types, the display will remain as is (NOT side by side format)
IF ",RR,RE,IE,OE,CA,CN,CX,CR,"[(","_ERXMTYPE_",")
Begin DoDot:1
+20 SET SDERXFLG=0
DO INIT^PSOERSE2(ERXIEN,SDERXFLG)
+21 IF $DATA(@VALMAR)
Begin DoDot:2
+22 IF $DATA(@VALMAR@(LINE))
SET LINE=LINE+1
+23 SET $PIECE(DDASH,"_",81)=""
DO SET^VALM10(LINE,DDASH)
+24 SET LINE=LINE+1
DO ERXRCVDT(ERXIEN)
+25 IF '$DATA(@VALMAR@(LINE))
SET LINE=LINE-1
DO CNTRL^VALM10(LINE,1,80,IOINHI,IOINORM)
+26 SET VALMCNT=LINE
End DoDot:2
End DoDot:1
QUIT
+27 ;
+28 ;side by side format begins here
+29 ;Display Patient data
DO SETPAT^PSOERUT0(MODE,ERXIEN,,NMSPC,0,1)
+30 SET EPRVIEN=$$GET1^DIQ(52.49,ERXIEN,2.1,"I")
+31 IF 'EPRVIEN
SET EPRVIEN=$$GETPROV^PSOERXU5(ERXIEN)
+32 ;Display Provider data
DO SETPROV^PSOERUT1(MODE,ERXIEN,,NMSPC,0,1)
+33 ;
+34 DO ERXDATA^PSOERXU9(.ERXDATA,ERXIEN)
+35 SET ERXDRGID=""
+36 IF $DATA(ERXDATA)
SET ERXDRGID=$PIECE(ERXDATA(1),"^",4)
+37 ;Display Drug Data
DO SETDRUG^PSOERUT2(MODE,NMSPC,ERXIEN,0,0,1)
+38 ;
+39 ;display erx written and issue/effective date
SET S2017=$$GET1^DIQ(52.49,PSOIEN,312.1,"I")
+40 DO S2017(MODE,NMSPC,ERXIEN,S2017)
+41 DO ALLERGY^PSOERUT3(MODE,NMSPC,ERXIEN,+$$GET1^DIQ(52.49,ERXIEN,.05,"I"))
+42 DO SETDIAGS^PSOERUT3(MODE,NMSPC,ERXIEN)
+43 ;
+44 ;display the eRx Received Date time stamp
DO ERXRCVDT(ERXIEN)
+45 ; DEA Note for CS Digitally Signed eRx records
+46 IF $$GET1^DIQ(52.49,PSOIEN,95.1,"I")
SET LINE=LINE-1
DO DEANOTE(.LINE)
+47 SET VALMCNT=LINE-1
+48 ; Changes the Video Attributes for the list
DO VIDEO^PSOERUT0()
+49 ;
HELP ; -- help code
+1 ;S X="?" D DISP^XQORM1 W !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL ERXSTATSD
+2 DO CLEAN^VALM10
+3 DO CLEAR^VALM1
+4 SET VALMBCK="R"
SET PSOREFSH=1
+5 QUIT
+6 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
ERXMTYPE(ERXIEN) ;Retrieve the message type in File 52.49
+1 ; Input: ERXIEN - Pointer to ERX HOLDING QUEUE file (#52.49)
+2 ;Output: Message Type Internal Value^Message Type External Value
+3 IF +$GET(ERXIEN)<1
QUIT ""
+4 NEW ERXMTYPE,ERTYPEX,STATIEN,ERXSTAT
+5 SET ERXMTYPE=""
+6 SET ERXMTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
+7 SET ERTYPEX=$$GET1^DIQ(52.49,ERXIEN,.08,"E")
+8 SET STATIEN=$$GET1^DIQ(52.49,ERXIEN,1,"I")
+9 SET ERXSTAT=$$GET1^DIQ(52.45,STATIEN,.02,"E")
+10 QUIT $GET(ERXMTYPE)_"^"_$GET(ERTYPEX)
+11 ;
ERXRCVDT(ERXIEN) ;
+1 NEW ERXRDT
+2 ;display the eRx Received Date time stamp
SET ERXRDT=$$GETERXRDT(ERXIEN)
+3 IF $GET(ERXRDT)'=""
Begin DoDot:1
+4 SET XE=" eRx Received on "_$PIECE(ERXRDT,"^")
+5 IF $PIECE(ERXRDT,"^",2)'=""
SET XE=XE_" - Accepted by "_$PIECE(ERXRDT,"^",2)_" on "_$PIECE(ERXRDT,"^",3)
+6 IF '$TEST
SET XE=" "_XE
+7 DO ADDLINE^PSOERUT0(MODE,NMSPC,$$COMPARE^PSOERUT0("LM",XE,XE,2))
End DoDot:1
+8 QUIT
+9 ;
S2017(MODE,NAMESPACE,ERXIEN,S2017) ;Retrieve erx written and effective/issue date
+1 NEW ERXWDATE,ERXEFFDT,WDATE,ERXDT,XE,XV,MIEN,X
+2 IF 'S2017
Begin DoDot:1
+3 SET WDATE=$$GET1^DIQ(52.49,ERXIEN,5.9,"I")\1
+4 SET ERXDT=$$GET1^DIQ(52.49,ERXIEN,.03,"I")
+5 SET XE="Written: "_$$COMPARE^PSOERUT0(MODE,$$FMTE^XLFDT(WDATE,"2Z"),$$FMTE^XLFDT(WDATE,"2Z"),10)
+6 SET XE=XE_" Effective: "_$$COMPARE^PSOERUT0(MODE,$$FMTE^XLFDT($PIECE(ERXDT,"."),"2Z"),$$FMTE^XLFDT($PIECE(ERXDT,"."),"2Z"),31)
+7 DO ADDLINE^PSOERUT0(MODE,NMSPC,XE,"|")
End DoDot:1
+8 IF S2017
Begin DoDot:1
+9 SET MIEN=$ORDER(^PS(52.49,ERXIEN,311,0))
+10 SET ERXEFFDT=""
SET X=$$EFFDATE^PSOERXU5(ERXIEN,MIEN)
IF X'=""
DO ^%DT
SET ERXEFFDT=Y
+11 SET ERXWDATE=$$GET1^DIQ(52.49,ERXIEN,5.9,"I")\1
+12 SET XE="Written: "_$$COMPARE^PSOERUT0(MODE,$$FMTE^XLFDT($PIECE(ERXWDATE,"."),"2Z"),$$FMTE^XLFDT($PIECE(ERXWDATE,"."),"2Z"),10)
+13 SET XE=XE_" Effective: "_$$COMPARE^PSOERUT0(MODE,$$FMTE^XLFDT(ERXEFFDT,"2Z"),$$FMTE^XLFDT(ERXEFFDT,"2Z"),31)
+14 DO ADDLINE^PSOERUT0(MODE,NMSPC,XE,"|")
End DoDot:1
+15 QUIT
+16 ;
GETHLDSTA(ERXHLDARY,ERXIEN) ;Retrieve the Erx Hold Status, Reason, and Hold By
+1 ; Input : ERXIEN - Pointer to ERX HOLDING QUEUE file (#52.49)
+2 ; Output: ERXHLDARY - An array which must be passed in by reference; returned with the following:
+3 ; ERXHLDARY(#)=value or if no hold status ERXHLDARY(0)=""
+4 ; Where:
+5 ; # - is a sequential number greater than zero
+6 ; value - is a line of text
+7 ; 1-Hold Status
+8 ; 2-Hold Reason
+9 ; 3-Hold Entered By
+10 NEW CURSTATE,CURSTATI,CNTR,HARY,HL,LHMATCH,LHFOUND,LHSTATI
+11 KILL ERXHLDARY
+12 ; only set the hold reason if the eRx has a hold status and hold reason contains data
+13 SET CURSTATE=$$GET1^DIQ(52.49,ERXIEN,1,"E")
+14 SET (VAHSTA,VAHREA,VAHPER)=""
+15 SET CNTR=0
+16 IF $EXTRACT(CURSTATE,1)="H"
Begin DoDot:1
+17 SET CURSTATI=$$GET1^DIQ(52.49,ERXIEN,1,"I")
+18 SET LHMATCH=999999
SET LHFOUND=0
FOR
SET LHMATCH=$ORDER(^PS(52.49,ERXIEN,19,LHMATCH),-1)
if 'LHMATCH!(LHFOUND)
QUIT
Begin DoDot:2
+19 SET LHSTATI=$$GET1^DIQ(52.4919,LHMATCH_","_ERXIEN_",",.02,"I")
IF LHSTATI=CURSTATI
Begin DoDot:3
+20 SET VAHSTA=$$GET1^DIQ(52.45,LHSTATI,.01,"E")_" - "_$$GET1^DIQ(52.45,LHSTATI,.02,"E")
SET CNTR=CNTR+1
SET ERXHLDARY($JOB,CNTR)=VAHSTA
+21 SET VAHPER=$$GET1^DIQ(52.4919,LHMATCH_","_ERXIEN_",",.03,"E")
SET CNTR=CNTR+1
SET ERXHLDARY($JOB,CNTR)=VAHPER
+22 SET VAHREA=$$GET1^DIQ(52.4919,LHMATCH_","_ERXIEN_",",1)
SET CNTR=CNTR+1
SET ERXHLDARY($JOB,CNTR)=VAHREA
End DoDot:3
SET LHFOUND=LHMATCH
QUIT
End DoDot:2
End DoDot:1
+23 IF CNTR<1
SET ERXHLDARY($JOB,0)=""
+24 QUIT $GET(CNTR)
+25 ;
GETERXRDT(ERXIEN) ;Retrieve the eRx Received Date time stamp
+1 ; Input : ERXIEN - Pointer to ERX HOLDING QUEUE file (#52.49)
+2 ; Output: ERXRADT - eRx Recieved Date time stamp^accepted by^date accepted
+3 ; Example: 1/19/24@14:05^LASTNAME,FIRSTNAME^9/26/24@10:30
+4 NEW ACCDTBY,ERXRADT
+5 if '$GET(ERXIEN)
QUIT
+6 SET ACCDTBY=$$ACCDTBY^PSOERUT4(ERXIEN)
+7 SET ERXRADT=$PIECE($$FMTE^XLFDT($$GET1^DIQ(52.49,ERXIEN,.03,"I"),"2Y"),":",1,2)
+8 SET ERXRADT=ERXRADT_"^"_$EXTRACT($PIECE(ACCDTBY,"^",2),1,17)_"^"_$PIECE($PIECE(ACCDTBY,"^",1),":",1,2)
+9 QUIT $GET(ERXRADT)
+10 ;
REF ;Screen Refresh
+1 IF $DATA(VALMEVL)
FOR I=1:1:99
DO RESTORE^VALM10(I)
+2 DO HDR
DO INIT
SET VALMBCK="R"
+3 QUIT
+4 ;
VO ; View Original eRx Action
+1 NEW ORERXIEN,ERX
+2 SET ORERXIEN=$$RELERX(ERXIEN,"N")
+3 IF ORERXIEN
SET (ERXIEN,PSOIEN)=ORERXIEN
+4 IF '$TEST
IF ORERXIEN=0
SET VALMSG="No Original eRx Found"
SET VALMBCK="R"
WRITE $CHAR(7)
QUIT
+5 DO REF
+6 QUIT
+7 ;
VRR ; View Request
+1 NEW RRERXIEN,ERX
+2 SET RRERXIEN=$$RELERX(ERXIEN,"RR,CR,CA")
+3 IF RRERXIEN
SET (ERXIEN,PSOIEN)=RRERXIEN
+4 IF '$TEST
IF RRERXIEN=0
SET VALMSG="No Request eRx Found"
SET VALMBCK="R"
WRITE $CHAR(7)
QUIT
+5 DO REF
+6 QUIT
+7 ;
VRE ; View Request Response
+1 NEW REERXIEN,ERX
+2 SET REERXIEN=$$RELERX(ERXIEN,"RE,CN,CX")
+3 IF REERXIEN
SET (ERXIEN,PSOIEN)=REERXIEN
+4 IF '$TEST
IF REERXIEN=0
SET VALMSG="No Response eRx Found"
SET VALMBCK="R"
WRITE $CHAR(7)
QUIT
+5 DO REF
+6 QUIT
+7 ;
RELERX(ERXIEN,MSGTYPE) ; Returns the Selected Related eRx IEN
+1 ; Input: ERXIEN - Pointer to ERX HOLDING QUEUE (#52.49)
+2 ; MSGTYPE - Relation types ("N":NewRx;"RR,CR,CA":Request;"RE,CN,CX":Response)
+3 ;Output: RELERX - Selected Related eRx (Original, Response, Request) - Pointer to #52.49 (0 if not found)
+4 NEW ERX,ERXARR,TMPARR,X,Y,DTOUT,DIROUT,SEQ,DIR,XX,RERX,REQIEN,RESIEN,ORIGIEN,MTYPE
+5 SET (SEQ,ERX)=0
+6 FOR
SET ERX=$ORDER(^PS(52.49,ERXIEN,201,"B",ERX))
if 'ERX
QUIT
Begin DoDot:1
+7 IF '$DATA(TMPARR(ERX))
IF ","_MSGTYPE_","[(","_$$GET1^DIQ(52.49,ERX,.08,"I")_",")
Begin DoDot:2
+8 SET SEQ=SEQ+1
SET ERXARR(SEQ)=ERX
SET TMPARR(ERX)=""
End DoDot:2
+9 IF '$TEST
SET RERX=0
FOR
SET RERX=$ORDER(^PS(52.49,ERX,201,"B",RERX))
if 'RERX
QUIT
Begin DoDot:2
+10 IF '$DATA(TMPARR(RERX))
IF ","_MSGTYPE_","[(","_$$GET1^DIQ(52.49,RERX,.08,"I")_",")
Begin DoDot:3
+11 SET SEQ=SEQ+1
SET ERXARR(SEQ)=RERX
SET TMPARR(RERX)=""
End DoDot:3
End DoDot:2
End DoDot:1
+12 ;
+13 IF '$DATA(ERXARR)
Begin DoDot:1
+14 SET MTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
+15 SET (ORIGIEN,REQIEN,RESIEN)=0
+16 IF ",RR,CA,CR,"[(","_MTYPE_",")
Begin DoDot:2
+17 SET REQIEN=ERXIEN
SET RESIEN=$$GETRESP^PSOERXU2(ERXIEN)
End DoDot:2
+18 IF ",RE,CN,CX,"[(","_MTYPE_",")
Begin DoDot:2
+19 SET RESIEN=ERXIEN
SET REQIEN=$$RESOLV^PSOERXU2(ERXIEN)
End DoDot:2
+20 IF MTYPE="IE"
Begin DoDot:2
+21 SET RESIEN=ERXIEN
SET REQIEN=$$RESOLV^PSOERXU2(ERXIEN)
End DoDot:2
+22 IF $GET(REQIEN)
Begin DoDot:2
+23 SET ORIGIEN=+$ORDER(^PS(52.49,"B",+$$GET1^DIQ(52.49,REQIEN,.14),0))
End DoDot:2
+24 IF MSGTYPE="N"
IF $GET(ORIGIEN)
IF ORIGIEN'=ERXIEN
SET SEQ=SEQ+1
SET ERXARR(SEQ)=ORIGIEN
+25 IF MSGTYPE="RR,CR,CA"
IF $GET(REQIEN)
SET SEQ=SEQ+1
SET ERXARR(SEQ)=REQIEN
+26 IF MSGTYPE="RE,CN,CX"
IF $GET(RESIEN)
SET SEQ=SEQ+1
SET ERXARR(SEQ)=RESIEN
End DoDot:1
+27 ;
+28 IF '$DATA(ERXARR)
QUIT 0
+29 IF '$DATA(ERXARR(2))
QUIT $GET(ERXARR(1))
+30 DO FULL^VALM1
+31 WRITE !!,"# ERX ID",?22,"ERX TYPE",?42,"STATUS",?50,"DATE/TIME"
+32 SET XX=""
SET $PIECE(XX,"-",72)=""
WRITE !,XX
+33 SET SEQ=0
FOR
SET SEQ=$ORDER(ERXARR(SEQ))
if 'SEQ
QUIT
Begin DoDot:1
+34 SET ERX=ERXARR(SEQ)
WRITE !,SEQ,?3,$$GET1^DIQ(52.49,ERX,.01),?22,$$GET1^DIQ(52.49,ERX,.08),?42,$$GET1^DIQ(52.49,ERX,1),?50,$$GET1^DIQ(52.49,ERX,.03)
End DoDot:1
+35 WRITE !
SET DIR(0)="L^1:"_$ORDER(ERXARR(999),-1)
SET DIR("A")="SELECT"
+36 DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)
QUIT "^"
+37 QUIT ERXARR(+Y)
+38 QUIT
+39 ;
DEANOTE(LINE) ;DEA Note for CS Digitally Signed eRx records
+1 NEW LINETXT
+2 SET LINE=LINE+1
DO SET^VALM10(LINE,"")
+3 SET LINE=LINE+1
SET LINETXT=" This prescription meets the requirements of the Drug Enforcement Administration"
+4 DO SET^VALM10(LINE,LINETXT)
DO CNTRL^VALM10(LINE,1,$LENGTH(LINETXT)+1,IOINHI,IOINORM)
+5 SET LINE=LINE+1
SET LINETXT=" (DEA) electronic prescribing for controlled substances rules (21 CFR Parts 1300,"
+6 DO SET^VALM10(LINE,LINETXT)
DO CNTRL^VALM10(LINE,1,$LENGTH(LINETXT)+1,IOINHI,IOINORM)
+7 SET LINE=LINE+1
SET LINETXT=" 1304, 1306, & 1311)."
+8 DO SET^VALM10(LINE,LINETXT)
DO CNTRL^VALM10(LINE,2,$LENGTH(LINETXT),IOINHI,IOINORM)
+9 SET LINE=LINE+1
+10 QUIT
