PSOERRX0 ;BIRM/MFR - All Rxs eRx Queue - ListManager ;08/28/22
;;7.0;OUTPATIENT PHARMACY;**700,746**;DEC 1997;Build 106
;
EN ; Entry point for the RX Action in the Patient Centric View
N STSFLTR,MATFLTR,REDTFLTR,PRVFLTR,DRGFLTR,MSTPFLTR,MTARR,PSODETDP
S MBMSITE=$S($$GET1^DIQ(59.7,1,102,"I")="MBM":1,1:0)
;
;Division selection
I '$G(PSOSITE) D ^PSOLSET I '$D(PSOPAR) W $C(7),!!,"Pharmacy Division Must be Selected!",! G EXIT
I '$G(PSNPINST) S PSNPINST=$$GET1^DIQ(59,PSOSITE,101,"I")
;
; Loading User's preferences
S MTARR("RR")="RXRENEWALREQUEST",MTARR("RE")="RXRENEWALRESPONSE",MTARR("N")="NEWRX(ALL)",MTARR("CR")="RXCHANGEREQUEST"
S MTARR("RXF")="RXFILL",MTARR("IE")="INBOUND ERROR",MTARR("OE")="OUTBOUND ERROR",MTARR("CA")="CANCELRX",MTARR("CN")="CANCELRXRESPONSE"
S MTARR("CX")="RXCHANGERESPONSE",MTARR("N")="NEWRX"
D LOAD^PSOERPR1
W !,"Please wait..."
D EN^VALM("PSO ERX ALL RXS QUEUE")
;
G EXIT
;
LMHDR ; ListMan Header Code
D SHOW^VALM,HDR^PSOERRX0
I $G(MBMSITE) S XQORM("B")="Next Screen"
S XQORM("#")=$O(^ORD(101,"B","PSO ERX ALL RXS SELECT",""))_"^1:"_VALMCNT
S XQORM("??")="D HELP^VALM2,HDR^PSOERRX0"
Q
;
HDR ; - Builds the Header section
D HDR^PSOERRX1
Q
;
INIT ;Populates the Body section for ListMan
N LOCKPATS,PAT
K ^TMP("PSOERRX0",$J),^TMP("PSOERRXS",$J)
S PAT=0 F S PAT=$O(^XTMP("PSOERXLOCK",PAT)) Q:'PAT S LOCKPATS(PAT)=+$G(^XTMP("PSOERXLOCK",PAT))
D SETSORT^PSOERRX1(PSOSRTBY),SETLINE
S:$G(VALMSG)="" VALMSG="Select the entry # to view or ?? for more actions"
Q
;
SETLINE ;Sets the line to be displayed in ListMan
N SORT,TYPE,STS,SUB,SEQ,LINE,Z,Z1,TOTAL,I,X,X1,ORDCNT,LBL,LN,GROUP,QTYL,ORNUM1,ERXIEN1,HIGHLN
N X,POS
K ^TMP("PSOERRX0",$J)
I '$D(^TMP("PSOERRXS",$J)) D Q
. F I=1:1:6 S ^TMP("PSOERRX0",$J,I,0)=""
. S ^TMP("PSOERRX0",$J,7,0)=" No prescriptions found."
. S VALMCNT=1
;
;Resetting list to NORMAL video attributes
D RESET^PSOERUT0() K GRPLN
;
;Building the list (line by line)
S (GROUP,SORT)="",(SEQ,LINE)=0,SORTORD=$S(PSORDER="A":1,1:-1)
F S GROUP=$O(^TMP("PSOERRXS",$J,GROUP)) Q:GROUP="" D
. I GROUP'="ALL" D
. . N LBL,POS,X
. . S LBL=$S(GROUP="NON-CS":"NON-",1:"")_"CONTROLLED SUBSTANCE Rx's"
. . S POS=41-($L(LBL)\2) S X="",$P(X," ",81)="",$E(X,POS,POS-1+$L(LBL))=LBL
. . S LINE=LINE+1,^TMP("PSOERRX0",$J,LINE,0)=X,GRPLN(LINE)=LBL
. F S SORT=$O(^TMP("PSOERRXS",$J,GROUP,SORT),SORTORD) Q:SORT="" D
. . S Z=$G(^TMP("PSOERRXS",$J,GROUP,SORT)),SEQ=SEQ+1
. . S Z1=$G(^TMP("PSOERRXS",$J,GROUP,SORT,"ERXIEN")),ERXIEN=+Z1
. . S X1=SEQ_$S(+$G(^PS(52.49,ERXIEN,95)):"]",1:".")
. . S $E(X1,$S(SEQ>999:6,1:5))=$E($P(Z,"^",1),1,$S(SEQ>999:19,1:20)),$E(X1,26)=$P(Z,"^",2),$E(X1,35)=$E($P(Z,"^",3),1,21)
. . I $G(MBMSITE),$E($P(Z,"^",5),1,3)="REM" S $P(Z,"^",5)="R"_$E($P(Z,"^",5),4,9)
. . S $E(X1,57)=$E($P(Z,"^",4),1,11),$E(X1,69)=$E($P(Z,"^",5),1,3),$E(X1,73)=$P(Z,"^",6)
. . S LINE=LINE+1,^TMP("PSOERRX0",$J,LINE,0)=X1,^TMP("PSOERRX0",$J,SEQ,"ERXIEN")=ERXIEN
. . I $P(Z1,"^",2) S HIGHLN(LINE)=1
. . I $G(PSODETDP) D SETDET^PSOERPT0(ERXIEN,.LINE,"PSOERRX0")
;
;Saving NORMAL video attributes to be reset later
I LINE>$G(LASTLINE) D
. F I=($G(LASTLINE)+1):1:LINE D SAVE^VALM10(I)
. S LASTLINE=LINE
D VIDEO^PSOERPT1()
S VALMCNT=+$G(LINE) D RV^PSOPMP1
Q
;
FLTRMT(MSGTYPE) ; Filter By Message Type Action
S MSTPFLTR=MSGTYPE
D REF S VALMBCK="R",VALMBG=1
Q
;
CS ;Group/Un-group Controlled Substances
S PSOCSGRP=$S($G(PSOCSGRP):0,1:1) D REF
Q
;
DET ;Display/Remove DET
S PSODETDP=$S($G(PSODETDP):0,1:1),LINE=0 D REF
I 'PSODETDP S VALMBG=VALMBG\2
I PSODETDP S VALMBG=VALMBG*2-1
S:VALMBG>(VALMCNT-10) VALMBG=VALMCNT-10 S:VALMBG<1 VALMBG=1
Q
;
CV ;Change View
D EN^PSOERPR1 I $G(PSORFRSH) D REF S VALMBG=1
S VALMBCK="R"
Q
;
SORT(FIELD) ;Sort entries by FIELD
I PSOSRTBY=FIELD S PSORDER=$S(PSORDER="A":"D",1:"A")
E S PSOSRTBY=FIELD,PSORDER="A"
D REF
Q
;
LBD ;Change Look Back Days Parameter Action
D FULL^VALM1 S VALMBCK="R"
W ! K DIR,DIRUT,DIROUT,SAVEX,DA
S DIR(0)="52.353,1",DIR("B")=PSOLKBKD
D ^DIR I $D(DIRUT)!$D(DIROUT) Q
S PSOLKBKD=Y,RESETLBD=0 D REF S VALMBG=1
Q
;
PC ;Patient Centri View Switch
D EN^PSOERPC0 S VALMBCK="Q"
Q
;
SEL ;Process selection of one entry
N PSOSEL,ERXIEN,ERXPTIEN
S VALMBCK="R"
S PSOSEL=+$P(XQORNOD(0),"=",2) I 'PSOSEL S VALMSG="Invalid selection!" Q
S ERXIEN=$G(^TMP("PSOERRX0",$J,PSOSEL,"ERXIEN")) I 'ERXIEN S VALMSG="Invalid selection!" Q
S ERXPTIEN=$$GETPAT^PSOERXU5(ERXIEN)
; - Locking the eRx Patient
I ERXPTIEN,'$$LOCK^PSOERPC1(ERXPTIEN) Q
; - Entering the eRx Record
D EN^PSOERX1(ERXIEN) K ERXIEN
; - Unlocking the eRx Patient
I ERXPTIEN D UL^PSOERX1A(ERXPTIEN)
I $G(PSORFRSH) D REF
Q
;
SQ ; - Search Queue Entry Point
D FULL^VALM1 S VALMBCK="R"
N DIR,DUOUT,DIRUT,Y,X,CHANGE,ERXLOCK,ERXPTIEN,PSOFPICK
S CHANGE=0
REP ; Re-Entry Point
K DIR S DIR("?",1)="Choose one or multiple filter criteria(s) to sort the current list."
S DIR("?",2)="To remove an existing filter type ^#, where '#' is the filter number below."
S DIR("?")=" "
S DIR("A")="SEARCH BY"
S DIR(0)="SO^1:ERX PATIENT" I $D(PATFLTR) S DIR(0)=DIR(0)_" "_IOINHI_"("_$$EPATFLST^PSOERUT(44)_")"_IOINORM
S DIR(0)=DIR(0)_";2:ERX DATE OF BIRTH" I $G(DOBFLTR) S DIR(0)=DIR(0)_" "_IOINHI_"("_$$FMTE^XLFDT(DOBFLTR,"2Z")_")"_IOINORM
S DIR(0)=DIR(0)_";3:RECEIVED DATE RANGE" I $G(REDTFLTR) S DIR(0)=DIR(0)_IOINHI_" ("_$$FMTE^XLFDT(+REDTFLTR,"2Z")_" TO "_$$FMTE^XLFDT($P(REDTFLTR,"^",2),"2Z")_")"_IOINORM
S DIR(0)=DIR(0)_";4:ERX PROVIDER" I $D(PRVFLTR) S DIR(0)=DIR(0)_" "_IOINHI_"("_$$EPRVFLST^PSOERUT(44)_")"_IOINORM
S DIR(0)=DIR(0)_";5:ERX STATUS" I $G(STSFLTR) S DIR(0)=DIR(0)_" "_IOINHI_"("_$$GET1^DIQ(52.45,+STSFLTR,.01)_")"_IOINORM
S DIR(0)=DIR(0)_";6:DRUG NAME" I $G(DRGFLTR)'="" S DIR(0)=DIR(0)_" "_IOINHI_"('"_DRGFLTR_"')"_IOINORM
S DIR(0)=DIR(0)_";7:MESSAGE TYPE" I $G(MSTPFLTR)'="" S DIR(0)=DIR(0)_" "_IOINHI_"("_MTARR(MSTPFLTR)_")"_IOINORM
S DIR(0)=DIR(0)_";8:ERX REFERENCE NUMBER"
S DIR(0)=DIR(0)_";9:VISTA RX #"
S DIR(0)=DIR(0)_";10:VISTA PATIENT" I $D(VPATFLTR) S DIR(0)=DIR(0)_" "_IOINHI_"("_$$VPATFLST^PSOERUT(44)_")"_IOINORM
S DIR(0)=DIR(0)_";11:VISTA PROVIDER" I $D(VPRVFLTR) S DIR(0)=DIR(0)_" "_IOINHI_"("_$$VPRVFLST^PSOERUT(44)_")"_IOINORM
S DIR(0)=DIR(0)_";12:MATCH STATUS" I $G(MATFLTR) S DIR(0)=DIR(0)_" "_IOINHI_"("_$$MATCHLBL^PSOERPC2(MATFLTR)_")"_IOINORM
D ^DIR
I X'="^",X?1"^".N D G REP
. K:X="^1" PATFLTR,VPATFLTR K:X="^2" DOBFLTR K:X="^3" REDTFLTR K:X="^4" PRVFLTR,VPRVFLTR K:X="^5" STSFLTR
. K:X="^6" DRGFLTR K:X="^7" MSTPFLTR K:X="^10" PATFLTR,VPATFLTR K:X="^11" PRVFLTR,VPRVFLTR K:X="^12" MATFLTR
. S CHANGE=1
I X=""!$D(DUOUT)!($D(DIRUT)) D:CHANGE REF S:CHANGE VALMBG=1 Q
S PSOFPICK=+$G(Y)
I PSOFPICK=1 D EPATFLTR^PSOERPC0 S CHANGE=1 G REP
I PSOFPICK=2 D DOBFLTR^PSOERPC0 S CHANGE=1 G REP
I PSOFPICK=3 D REDTFLTR S CHANGE=1 G REP
I PSOFPICK=4 D PRVFLTR S CHANGE=1 G REP
I PSOFPICK=5 D STSFLTR S CHANGE=1 G REP
I PSOFPICK=6 D S CHANGE=1 G REP
. D DRGFLTR
I PSOFPICK=7 D MSTPFLTR S CHANGE=1 G REP
I PSOFPICK=8 D ERXFLTR^PSOERPC0 G:'$G(ERXFLTR) REP D I '$G(CHANGE) Q
. ; - Entering the eRx Record
. D EN^PSOERX1(ERXFLTR)
. ; - Unlocking the eRx Patient
. S ERXPTIEN=$$GET1^DIQ(52.49,ERXFLTR,.04,"I") Q:'ERXPTIEN
. D UL^PSOERX1A(ERXPTIEN)
. S CHANGE=1
I PSOFPICK=9 D RXFLTR^PSOERPC0 G:'$G(ERXFLTR) REP D I '$G(CHANGE) Q
. ; - Entering the eRx Record
. D EN^PSOERX1(ERXFLTR)
. ; - Unlocking the eRx Patient
. S ERXPTIEN=$$GET1^DIQ(52.49,ERXFLTR,.04,"I") Q:'ERXPTIEN
. D UL^PSOERX1A(ERXPTIEN)
. S CHANGE=1
I PSOFPICK=10 D VPATFLTR^PSOERPC0 S CHANGE=1 G REP
I PSOFPICK=11 D VPRVFLTR^PSOERRX1 S CHANGE=1 G REP
I PSOFPICK=12 D MATFLTR^PSOERPC0 S CHANGE=1 G REP
D REF S VALMBG=1
Q
;
REDTFLTR ; - Received Date Range Filter
N %DT,PSOFROM,PSOTO,Y,DTOUT,DIROUT
S %DT(0)=-DT,%DT="AEP",%DT("A")="BEGIN DATE: "
S %DT("B")="T-45" I $P($G(REDTFLTR),"^") S %DT("B")=$$FMTE^XLFDT($P($G(REDTFLTR),"^"),"5Z")
W ! D ^%DT I Y<0!($D(DTOUT)) Q
S PSOFROM=Y\1
;
K %DT S %DT(0)=PSOFROM\1,%DT="AEP",%DT("A")="END DATE: "
S %DT("B")="TODAY" I $P($G(REDTFLTR),"^",2) S %DT("B")=$$FMTE^XLFDT($P($G(REDTFLTR),"^",2),"5Z")
W ! D ^%DT I Y<0!($D(DTOUT)) Q
S PSOTO=Y\1
;
S REDTFLTR=PSOFROM_"^"_PSOTO
Q
;
PRVFLTR ; - eRx Provider Filter
N DIR,PRV,XX,PRVLST,RANGE,COMSEG,I,J,DIRUT,DIROUT,QUIT
S DIR(0)="F^3:30",DIR("A")="ERX PROVIDER NAME"
W ! D ^DIR I $D(DIRUT)!$D(DIROUT) Q
D FIND^DIC(52.48,"","@;.01;1.5;1.6;4.3;4.4;IX","",X,,"B","","","PRVLST")
I '$D(PRVLST("DILIST",2)) W !,"No eRx Provider found" K PRVLST G PRVFLTR
;
W !!,"#",?4,"ERX PROVIDER NAME",?35,"NPI",?48,"CITY",?68,"STATE"
S (QUIT,CNT)=0,$P(XX,"-",80)="" W !,XX K DIRUT,DTOUT
S PRV="" F S PRV=$O(PRVLST("DILIST","ID",PRV)) Q:'PRV D I QUIT Q
. W !,PRV,".",?4,$E(PRVLST("DILIST","ID",PRV,.01),1,30),?35,PRVLST("DILIST","ID",PRV,1.5)
. W ?48,$E(PRVLST("DILIST","ID",PRV,4.3),1,20),?68,$$STATEABB^PSOERUT(52.48,PRVLST("DILIST",2,PRV))
. S CNT=CNT+1
. I CNT>18,$O(PRVLST("DILIST","ID",PRV)),$Y>(IOSL-4) D
. . K DIR S DIR(0)="E" D ^DIR I $D(DIRUT)!$D(DIROUT) S QUIT=1 Q
. . W @IOF,!,"#",?4,"ERX PROVIDER NAME",?35,"NPI",?48,"CITY",?68,"STATE",!,XX
;
K DIR S DIR("A")="SELECT (1-"_+$G(PRVLST("DILIST",0))_"): "
S DIR(0)="LA^1:"_+$G(PRVLST("DILIST",0)) W ! D ^DIR I $D(DIRUT)!$D(DIROUT) G PRVFLTR
S RANGE=X
;
K PRVFLTR
F I=1:1:$L(RANGE,",") D
. S COMSEG=$P(RANGE,",",I)
. F J=+COMSEG:1:$S(COMSEG["-":$P(COMSEG,"-",2),1:+COMSEG) D
. . I '$D(PRVLST("DILIST",2,J)) Q
. . S PRVFLTR(PRVLST("DILIST",2,J))=""
Q
;
MSTPFLTR ; - Message Type Filter
K DIR,DIRUT,DIROUT,X,Y
W ! S DIR(0)="52.49,.08" S:$G(MSTPFLTR)'="" DIR("B")=MSTPFLTR
D ^DIR I $D(DIRUT)!$D(DIROUT) Q
S MSTPFLTR=Y
Q
;
STSFLTR ; - eRx Status Filter
; prompt for erx status
N DIC,Y,DTOUT,DUOUT
I $G(STSFLTR) S DIC("B")=$$GET1^DIQ(52.45,STSFLTR,.01)
S DIC("A")="ERX STATUS: ",DIC=52.45,DIC(0)="AEQ",DIC("S")="I $D(^PS(52.45,""TYPE"",""ERX"",Y))"
; MbM Sites only - Allow selection of Removed Reasons as Status
I $G(MBMSITE) S DIC("S")=DIC("S")_"!$D(^PS(52.45,""TYPE"",""REM"",Y))"
W ! D ^DIC I Y<1 Q
S STSFLTR=+Y
Q
;
DRGFLTR ; - eRx Drug Name Filter
N DIR,X,Y,DIRUT,DIROUT
S DIR(0)="F^3:30",DIR("A")="DRUG NAME"
W ! D ^DIR I $D(DIRUT)!$D(DIROUT) Q
S DRGFLTR=Y
Q
;
RF ; Remove All Filters
K PATFLTR,VPATFLTR,DOBFLTR,REDTFLTR,PRVFLTR,VPRVFLTR,STSFLTR,MSTPFLTR,DRGFLTR,MATFLTR
D REF S VALMBG=1
Q
;
REF ;Screen Refresh
W ?52,"Please wait..." D INIT,HDR S VALMBCK="R"
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ;
K ^TMP("PSOERRX0",$J),^TMP("PSOERRXS",$J)
D FULL^VALM1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOERRX0 10850 printed Oct 16, 2024@18:28:32 Page 2
PSOERRX0 ;BIRM/MFR - All Rxs eRx Queue - ListManager ;08/28/22
+1 ;;7.0;OUTPATIENT PHARMACY;**700,746**;DEC 1997;Build 106
+2 ;
EN ; Entry point for the RX Action in the Patient Centric View
+1 NEW STSFLTR,MATFLTR,REDTFLTR,PRVFLTR,DRGFLTR,MSTPFLTR,MTARR,PSODETDP
+2 SET MBMSITE=$SELECT($$GET1^DIQ(59.7,1,102,"I")="MBM":1,1:0)
+3 ;
+4 ;Division selection
+5 IF '$GET(PSOSITE)
DO ^PSOLSET
IF '$DATA(PSOPAR)
WRITE $CHAR(7),!!,"Pharmacy Division Must be Selected!",!
GOTO EXIT
+6 IF '$GET(PSNPINST)
SET PSNPINST=$$GET1^DIQ(59,PSOSITE,101,"I")
+7 ;
+8 ; Loading User's preferences
+9 SET MTARR("RR")="RXRENEWALREQUEST"
SET MTARR("RE")="RXRENEWALRESPONSE"
SET MTARR("N")="NEWRX(ALL)"
SET MTARR("CR")="RXCHANGEREQUEST"
+10 SET MTARR("RXF")="RXFILL"
SET MTARR("IE")="INBOUND ERROR"
SET MTARR("OE")="OUTBOUND ERROR"
SET MTARR("CA")="CANCELRX"
SET MTARR("CN")="CANCELRXRESPONSE"
+11 SET MTARR("CX")="RXCHANGERESPONSE"
SET MTARR("N")="NEWRX"
+12 DO LOAD^PSOERPR1
+13 WRITE !,"Please wait..."
+14 DO EN^VALM("PSO ERX ALL RXS QUEUE")
+15 ;
+16 GOTO EXIT
+17 ;
LMHDR ; ListMan Header Code
+1 DO SHOW^VALM
DO HDR^PSOERRX0
+2 IF $GET(MBMSITE)
SET XQORM("B")="Next Screen"
+3 SET XQORM("#")=$ORDER(^ORD(101,"B","PSO ERX ALL RXS SELECT",""))_"^1:"_VALMCNT
+4 SET XQORM("??")="D HELP^VALM2,HDR^PSOERRX0"
+5 QUIT
+6 ;
HDR ; - Builds the Header section
+1 DO HDR^PSOERRX1
+2 QUIT
+3 ;
INIT ;Populates the Body section for ListMan
+1 NEW LOCKPATS,PAT
+2 KILL ^TMP("PSOERRX0",$JOB),^TMP("PSOERRXS",$JOB)
+3 SET PAT=0
FOR
SET PAT=$ORDER(^XTMP("PSOERXLOCK",PAT))
if 'PAT
QUIT
SET LOCKPATS(PAT)=+$GET(^XTMP("PSOERXLOCK",PAT))
+4 DO SETSORT^PSOERRX1(PSOSRTBY)
DO SETLINE
+5 if $GET(VALMSG)=""
SET VALMSG="Select the entry # to view or ?? for more actions"
+6 QUIT
+7 ;
SETLINE ;Sets the line to be displayed in ListMan
+1 NEW SORT,TYPE,STS,SUB,SEQ,LINE,Z,Z1,TOTAL,I,X,X1,ORDCNT,LBL,LN,GROUP,QTYL,ORNUM1,ERXIEN1,HIGHLN
+2 NEW X,POS
+3 KILL ^TMP("PSOERRX0",$JOB)
+4 IF '$DATA(^TMP("PSOERRXS",$JOB))
Begin DoDot:1
+5 FOR I=1:1:6
SET ^TMP("PSOERRX0",$JOB,I,0)=""
+6 SET ^TMP("PSOERRX0",$JOB,7,0)=" No prescriptions found."
+7 SET VALMCNT=1
End DoDot:1
QUIT
+8 ;
+9 ;Resetting list to NORMAL video attributes
+10 DO RESET^PSOERUT0()
KILL GRPLN
+11 ;
+12 ;Building the list (line by line)
+13 SET (GROUP,SORT)=""
SET (SEQ,LINE)=0
SET SORTORD=$SELECT(PSORDER="A":1,1:-1)
+14 FOR
SET GROUP=$ORDER(^TMP("PSOERRXS",$JOB,GROUP))
if GROUP=""
QUIT
Begin DoDot:1
+15 IF GROUP'="ALL"
Begin DoDot:2
+16 NEW LBL,POS,X
+17 SET LBL=$SELECT(GROUP="NON-CS":"NON-",1:"")_"CONTROLLED SUBSTANCE Rx's"
+18 SET POS=41-($LENGTH(LBL)\2)
SET X=""
SET $PIECE(X," ",81)=""
SET $EXTRACT(X,POS,POS-1+$LENGTH(LBL))=LBL
+19 SET LINE=LINE+1
SET ^TMP("PSOERRX0",$JOB,LINE,0)=X
SET GRPLN(LINE)=LBL
End DoDot:2
+20 FOR
SET SORT=$ORDER(^TMP("PSOERRXS",$JOB,GROUP,SORT),SORTORD)
if SORT=""
QUIT
Begin DoDot:2
+21 SET Z=$GET(^TMP("PSOERRXS",$JOB,GROUP,SORT))
SET SEQ=SEQ+1
+22 SET Z1=$GET(^TMP("PSOERRXS",$JOB,GROUP,SORT,"ERXIEN"))
SET ERXIEN=+Z1
+23 SET X1=SEQ_$SELECT(+$GET(^PS(52.49,ERXIEN,95)):"]",1:".")
+24 SET $EXTRACT(X1,$SELECT(SEQ>999:6,1:5))=$EXTRACT($PIECE(Z,"^",1),1,$SELECT(SEQ>999:19,1:20))
SET $EXTRACT(X1,26)=$PIECE(Z,"^",2)
SET $EXTRACT(X1,35)=$EXTRACT($PIECE(Z,"^",3),1,21)
+25 IF $GET(MBMSITE)
IF $EXTRACT($PIECE(Z,"^",5),1,3)="REM"
SET $PIECE(Z,"^",5)="R"_$EXTRACT($PIECE(Z,"^",5),4,9)
+26 SET $EXTRACT(X1,57)=$EXTRACT($PIECE(Z,"^",4),1,11)
SET $EXTRACT(X1,69)=$EXTRACT($PIECE(Z,"^",5),1,3)
SET $EXTRACT(X1,73)=$PIECE(Z,"^",6)
+27 SET LINE=LINE+1
SET ^TMP("PSOERRX0",$JOB,LINE,0)=X1
SET ^TMP("PSOERRX0",$JOB,SEQ,"ERXIEN")=ERXIEN
+28 IF $PIECE(Z1,"^",2)
SET HIGHLN(LINE)=1
+29 IF $GET(PSODETDP)
DO SETDET^PSOERPT0(ERXIEN,.LINE,"PSOERRX0")
End DoDot:2
End DoDot:1
+30 ;
+31 ;Saving NORMAL video attributes to be reset later
+32 IF LINE>$GET(LASTLINE)
Begin DoDot:1
+33 FOR I=($GET(LASTLINE)+1):1:LINE
DO SAVE^VALM10(I)
+34 SET LASTLINE=LINE
End DoDot:1
+35 DO VIDEO^PSOERPT1()
+36 SET VALMCNT=+$GET(LINE)
DO RV^PSOPMP1
+37 QUIT
+38 ;
FLTRMT(MSGTYPE) ; Filter By Message Type Action
+1 SET MSTPFLTR=MSGTYPE
+2 DO REF
SET VALMBCK="R"
SET VALMBG=1
+3 QUIT
+4 ;
CS ;Group/Un-group Controlled Substances
+1 SET PSOCSGRP=$SELECT($GET(PSOCSGRP):0,1:1)
DO REF
+2 QUIT
+3 ;
DET ;Display/Remove DET
+1 SET PSODETDP=$SELECT($GET(PSODETDP):0,1:1)
SET LINE=0
DO REF
+2 IF 'PSODETDP
SET VALMBG=VALMBG\2
+3 IF PSODETDP
SET VALMBG=VALMBG*2-1
+4 if VALMBG>(VALMCNT-10)
SET VALMBG=VALMCNT-10
if VALMBG<1
SET VALMBG=1
+5 QUIT
+6 ;
CV ;Change View
+1 DO EN^PSOERPR1
IF $GET(PSORFRSH)
DO REF
SET VALMBG=1
+2 SET VALMBCK="R"
+3 QUIT
+4 ;
SORT(FIELD) ;Sort entries by FIELD
+1 IF PSOSRTBY=FIELD
SET PSORDER=$SELECT(PSORDER="A":"D",1:"A")
+2 IF '$TEST
SET PSOSRTBY=FIELD
SET PSORDER="A"
+3 DO REF
+4 QUIT
+5 ;
LBD ;Change Look Back Days Parameter Action
+1 DO FULL^VALM1
SET VALMBCK="R"
+2 WRITE !
KILL DIR,DIRUT,DIROUT,SAVEX,DA
+3 SET DIR(0)="52.353,1"
SET DIR("B")=PSOLKBKD
+4 DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)
QUIT
+5 SET PSOLKBKD=Y
SET RESETLBD=0
DO REF
SET VALMBG=1
+6 QUIT
+7 ;
PC ;Patient Centri View Switch
+1 DO EN^PSOERPC0
SET VALMBCK="Q"
+2 QUIT
+3 ;
SEL ;Process selection of one entry
+1 NEW PSOSEL,ERXIEN,ERXPTIEN
+2 SET VALMBCK="R"
+3 SET PSOSEL=+$PIECE(XQORNOD(0),"=",2)
IF 'PSOSEL
SET VALMSG="Invalid selection!"
QUIT
+4 SET ERXIEN=$GET(^TMP("PSOERRX0",$JOB,PSOSEL,"ERXIEN"))
IF 'ERXIEN
SET VALMSG="Invalid selection!"
QUIT
+5 SET ERXPTIEN=$$GETPAT^PSOERXU5(ERXIEN)
+6 ; - Locking the eRx Patient
+7 IF ERXPTIEN
IF '$$LOCK^PSOERPC1(ERXPTIEN)
QUIT
+8 ; - Entering the eRx Record
+9 DO EN^PSOERX1(ERXIEN)
KILL ERXIEN
+10 ; - Unlocking the eRx Patient
+11 IF ERXPTIEN
DO UL^PSOERX1A(ERXPTIEN)
+12 IF $GET(PSORFRSH)
DO REF
+13 QUIT
+14 ;
SQ ; - Search Queue Entry Point
+1 DO FULL^VALM1
SET VALMBCK="R"
+2 NEW DIR,DUOUT,DIRUT,Y,X,CHANGE,ERXLOCK,ERXPTIEN,PSOFPICK
+3 SET CHANGE=0
REP ; Re-Entry Point
+1 KILL DIR
SET DIR("?",1)="Choose one or multiple filter criteria(s) to sort the current list."
+2 SET DIR("?",2)="To remove an existing filter type ^#, where '#' is the filter number below."
+3 SET DIR("?")=" "
+4 SET DIR("A")="SEARCH BY"
+5 SET DIR(0)="SO^1:ERX PATIENT"
IF $DATA(PATFLTR)
SET DIR(0)=DIR(0)_" "_IOINHI_"("_$$EPATFLST^PSOERUT(44)_")"_IOINORM
+6 SET DIR(0)=DIR(0)_";2:ERX DATE OF BIRTH"
IF $GET(DOBFLTR)
SET DIR(0)=DIR(0)_" "_IOINHI_"("_$$FMTE^XLFDT(DOBFLTR,"2Z")_")"_IOINORM
+7 SET DIR(0)=DIR(0)_";3:RECEIVED DATE RANGE"
IF $GET(REDTFLTR)
SET DIR(0)=DIR(0)_IOINHI_" ("_$$FMTE^XLFDT(+REDTFLTR,"2Z")_" TO "_$$FMTE^XLFDT($PIECE(REDTFLTR,"^",2),"2Z")_")"_IOINORM
+8 SET DIR(0)=DIR(0)_";4:ERX PROVIDER"
IF $DATA(PRVFLTR)
SET DIR(0)=DIR(0)_" "_IOINHI_"("_$$EPRVFLST^PSOERUT(44)_")"_IOINORM
+9 SET DIR(0)=DIR(0)_";5:ERX STATUS"
IF $GET(STSFLTR)
SET DIR(0)=DIR(0)_" "_IOINHI_"("_$$GET1^DIQ(52.45,+STSFLTR,.01)_")"_IOINORM
+10 SET DIR(0)=DIR(0)_";6:DRUG NAME"
IF $GET(DRGFLTR)'=""
SET DIR(0)=DIR(0)_" "_IOINHI_"('"_DRGFLTR_"')"_IOINORM
+11 SET DIR(0)=DIR(0)_";7:MESSAGE TYPE"
IF $GET(MSTPFLTR)'=""
SET DIR(0)=DIR(0)_" "_IOINHI_"("_MTARR(MSTPFLTR)_")"_IOINORM
+12 SET DIR(0)=DIR(0)_";8:ERX REFERENCE NUMBER"
+13 SET DIR(0)=DIR(0)_";9:VISTA RX #"
+14 SET DIR(0)=DIR(0)_";10:VISTA PATIENT"
IF $DATA(VPATFLTR)
SET DIR(0)=DIR(0)_" "_IOINHI_"("_$$VPATFLST^PSOERUT(44)_")"_IOINORM
+15 SET DIR(0)=DIR(0)_";11:VISTA PROVIDER"
IF $DATA(VPRVFLTR)
SET DIR(0)=DIR(0)_" "_IOINHI_"("_$$VPRVFLST^PSOERUT(44)_")"_IOINORM
+16 SET DIR(0)=DIR(0)_";12:MATCH STATUS"
IF $GET(MATFLTR)
SET DIR(0)=DIR(0)_" "_IOINHI_"("_$$MATCHLBL^PSOERPC2(MATFLTR)_")"_IOINORM
+17 DO ^DIR
+18 IF X'="^"
IF X?1"^".N
Begin DoDot:1
+19 if X="^1"
KILL PATFLTR,VPATFLTR
if X="^2"
KILL DOBFLTR
if X="^3"
KILL REDTFLTR
if X="^4"
KILL PRVFLTR,VPRVFLTR
if X="^5"
KILL STSFLTR
+20 if X="^6"
KILL DRGFLTR
if X="^7"
KILL MSTPFLTR
if X="^10"
KILL PATFLTR,VPATFLTR
if X="^11"
KILL PRVFLTR,VPRVFLTR
if X="^12"
KILL MATFLTR
+21 SET CHANGE=1
End DoDot:1
GOTO REP
+22 IF X=""!$DATA(DUOUT)!($DATA(DIRUT))
if CHANGE
DO REF
if CHANGE
SET VALMBG=1
QUIT
+23 SET PSOFPICK=+$GET(Y)
+24 IF PSOFPICK=1
DO EPATFLTR^PSOERPC0
SET CHANGE=1
GOTO REP
+25 IF PSOFPICK=2
DO DOBFLTR^PSOERPC0
SET CHANGE=1
GOTO REP
+26 IF PSOFPICK=3
DO REDTFLTR
SET CHANGE=1
GOTO REP
+27 IF PSOFPICK=4
DO PRVFLTR
SET CHANGE=1
GOTO REP
+28 IF PSOFPICK=5
DO STSFLTR
SET CHANGE=1
GOTO REP
+29 IF PSOFPICK=6
Begin DoDot:1
+30 DO DRGFLTR
End DoDot:1
SET CHANGE=1
GOTO REP
+31 IF PSOFPICK=7
DO MSTPFLTR
SET CHANGE=1
GOTO REP
+32 IF PSOFPICK=8
DO ERXFLTR^PSOERPC0
if '$GET(ERXFLTR)
GOTO REP
Begin DoDot:1
+33 ; - Entering the eRx Record
+34 DO EN^PSOERX1(ERXFLTR)
+35 ; - Unlocking the eRx Patient
+36 SET ERXPTIEN=$$GET1^DIQ(52.49,ERXFLTR,.04,"I")
if 'ERXPTIEN
QUIT
+37 DO UL^PSOERX1A(ERXPTIEN)
+38 SET CHANGE=1
End DoDot:1
IF '$GET(CHANGE)
QUIT
+39 IF PSOFPICK=9
DO RXFLTR^PSOERPC0
if '$GET(ERXFLTR)
GOTO REP
Begin DoDot:1
+40 ; - Entering the eRx Record
+41 DO EN^PSOERX1(ERXFLTR)
+42 ; - Unlocking the eRx Patient
+43 SET ERXPTIEN=$$GET1^DIQ(52.49,ERXFLTR,.04,"I")
if 'ERXPTIEN
QUIT
+44 DO UL^PSOERX1A(ERXPTIEN)
+45 SET CHANGE=1
End DoDot:1
IF '$GET(CHANGE)
QUIT
+46 IF PSOFPICK=10
DO VPATFLTR^PSOERPC0
SET CHANGE=1
GOTO REP
+47 IF PSOFPICK=11
DO VPRVFLTR^PSOERRX1
SET CHANGE=1
GOTO REP
+48 IF PSOFPICK=12
DO MATFLTR^PSOERPC0
SET CHANGE=1
GOTO REP
+49 DO REF
SET VALMBG=1
+50 QUIT
+51 ;
REDTFLTR ; - Received Date Range Filter
+1 NEW %DT,PSOFROM,PSOTO,Y,DTOUT,DIROUT
+2 SET %DT(0)=-DT
SET %DT="AEP"
SET %DT("A")="BEGIN DATE: "
+3 SET %DT("B")="T-45"
IF $PIECE($GET(REDTFLTR),"^")
SET %DT("B")=$$FMTE^XLFDT($PIECE($GET(REDTFLTR),"^"),"5Z")
+4 WRITE !
DO ^%DT
IF Y<0!($DATA(DTOUT))
QUIT
+5 SET PSOFROM=Y\1
+6 ;
+7 KILL %DT
SET %DT(0)=PSOFROM\1
SET %DT="AEP"
SET %DT("A")="END DATE: "
+8 SET %DT("B")="TODAY"
IF $PIECE($GET(REDTFLTR),"^",2)
SET %DT("B")=$$FMTE^XLFDT($PIECE($GET(REDTFLTR),"^",2),"5Z")
+9 WRITE !
DO ^%DT
IF Y<0!($DATA(DTOUT))
QUIT
+10 SET PSOTO=Y\1
+11 ;
+12 SET REDTFLTR=PSOFROM_"^"_PSOTO
+13 QUIT
+14 ;
PRVFLTR ; - eRx Provider Filter
+1 NEW DIR,PRV,XX,PRVLST,RANGE,COMSEG,I,J,DIRUT,DIROUT,QUIT
+2 SET DIR(0)="F^3:30"
SET DIR("A")="ERX PROVIDER NAME"
+3 WRITE !
DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)
QUIT
+4 DO FIND^DIC(52.48,"","@;.01;1.5;1.6;4.3;4.4;IX","",X,,"B","","","PRVLST")
+5 IF '$DATA(PRVLST("DILIST",2))
WRITE !,"No eRx Provider found"
KILL PRVLST
GOTO PRVFLTR
+6 ;
+7 WRITE !!,"#",?4,"ERX PROVIDER NAME",?35,"NPI",?48,"CITY",?68,"STATE"
+8 SET (QUIT,CNT)=0
SET $PIECE(XX,"-",80)=""
WRITE !,XX
KILL DIRUT,DTOUT
+9 SET PRV=""
FOR
SET PRV=$ORDER(PRVLST("DILIST","ID",PRV))
if 'PRV
QUIT
Begin DoDot:1
+10 WRITE !,PRV,".",?4,$EXTRACT(PRVLST("DILIST","ID",PRV,.01),1,30),?35,PRVLST("DILIST","ID",PRV,1.5)
+11 WRITE ?48,$EXTRACT(PRVLST("DILIST","ID",PRV,4.3),1,20),?68,$$STATEABB^PSOERUT(52.48,PRVLST("DILIST",2,PRV))
+12 SET CNT=CNT+1
+13 IF CNT>18
IF $ORDER(PRVLST("DILIST","ID",PRV))
IF $Y>(IOSL-4)
Begin DoDot:2
+14 KILL DIR
SET DIR(0)="E"
DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)
SET QUIT=1
QUIT
+15 WRITE @IOF,!,"#",?4,"ERX PROVIDER NAME",?35,"NPI",?48,"CITY",?68,"STATE",!,XX
End DoDot:2
End DoDot:1
IF QUIT
QUIT
+16 ;
+17 KILL DIR
SET DIR("A")="SELECT (1-"_+$GET(PRVLST("DILIST",0))_"): "
+18 SET DIR(0)="LA^1:"_+$GET(PRVLST("DILIST",0))
WRITE !
DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)
GOTO PRVFLTR
+19 SET RANGE=X
+20 ;
+21 KILL PRVFLTR
+22 FOR I=1:1:$LENGTH(RANGE,",")
Begin DoDot:1
+23 SET COMSEG=$PIECE(RANGE,",",I)
+24 FOR J=+COMSEG:1:$SELECT(COMSEG["-":$PIECE(COMSEG,"-",2),1:+COMSEG)
Begin DoDot:2
+25 IF '$DATA(PRVLST("DILIST",2,J))
QUIT
+26 SET PRVFLTR(PRVLST("DILIST",2,J))=""
End DoDot:2
End DoDot:1
+27 QUIT
+28 ;
MSTPFLTR ; - Message Type Filter
+1 KILL DIR,DIRUT,DIROUT,X,Y
+2 WRITE !
SET DIR(0)="52.49,.08"
if $GET(MSTPFLTR)'=""
SET DIR("B")=MSTPFLTR
+3 DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)
QUIT
+4 SET MSTPFLTR=Y
+5 QUIT
+6 ;
STSFLTR ; - eRx Status Filter
+1 ; prompt for erx status
+2 NEW DIC,Y,DTOUT,DUOUT
+3 IF $GET(STSFLTR)
SET DIC("B")=$$GET1^DIQ(52.45,STSFLTR,.01)
+4 SET DIC("A")="ERX STATUS: "
SET DIC=52.45
SET DIC(0)="AEQ"
SET DIC("S")="I $D(^PS(52.45,""TYPE"",""ERX"",Y))"
+5 ; MbM Sites only - Allow selection of Removed Reasons as Status
+6 IF $GET(MBMSITE)
SET DIC("S")=DIC("S")_"!$D(^PS(52.45,""TYPE"",""REM"",Y))"
+7 WRITE !
DO ^DIC
IF Y<1
QUIT
+8 SET STSFLTR=+Y
+9 QUIT
+10 ;
DRGFLTR ; - eRx Drug Name Filter
+1 NEW DIR,X,Y,DIRUT,DIROUT
+2 SET DIR(0)="F^3:30"
SET DIR("A")="DRUG NAME"
+3 WRITE !
DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)
QUIT
+4 SET DRGFLTR=Y
+5 QUIT
+6 ;
RF ; Remove All Filters
+1 KILL PATFLTR,VPATFLTR,DOBFLTR,REDTFLTR,PRVFLTR,VPRVFLTR,STSFLTR,MSTPFLTR,DRGFLTR,MATFLTR
+2 DO REF
SET VALMBG=1
+3 QUIT
+4 ;
REF ;Screen Refresh
+1 WRITE ?52,"Please wait..."
DO INIT
DO HDR
SET VALMBCK="R"
+2 QUIT
+3 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ;
+1 KILL ^TMP("PSOERRX0",$JOB),^TMP("PSOERRXS",$JOB)
+2 DO FULL^VALM1
+3 QUIT
