Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSOERSE1

PSOERSE1.m

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