PSOERPT0 ;BIRM/MFR - eRx Single Patient Queue - ListManager ; 12/10/22 9:53am
;;7.0;OUTPATIENT PHARMACY;**700,746,770**;DEC 1997;Build 145
;
EN ;Menu option entry point
N PSNPINST,PSOSRTBY,PSORDER,PSODETDP,PSOSTSGP,PSOSTORD,PSORDCNT,PSOSTSEQ,PSORDSEQ,PSOCHNG
N GRPLN,DIC,Y,DFN,HIGHLN,LASTLINE,VALMCNT,NPALERT,PSOCSGRP,PSOIEN,ERXIEN
;
;Division selection
I '$G(PSOSITE) D FULL^VALM1 D ^PSOLSET I '$D(PSOPAR) W $C(7),!!,"Pharmacy Division Must be Selected!",! G EXIT
S PSNPINST=$$GET1^DIQ(59,PSOSITE,101,"I")
;
;Patient selection
W !! S DIC=52.46,DIC(0)="QEAM",DIC("A")="ERX PATIENT: "
D ^DIC G EXIT:Y<0 S EPATIEN=+Y
D LST(EPATIEN)
G EXIT
Q
;
LST(EPATIEN) ; ListMan Action Entry point
;Input: EPATIEN - Pointer to the eRx PATIENT (#52.46)
; Loading Division/User preferences
D LOAD^PSOERPR2
W !,"Please wait..."
D EN^VALM("PSO ERX SINGLE PATIENT QUEUE")
;
G EXIT
;
LMHDR ; Menu Protocol Header Code
D SHOW^VALM,HDR
S:($G(PSOSTFLT)="WP") XQORM("B")="NP"
S XQORM("#")=$O(^ORD(101,"B","PSO ERX SINGLE PATIENT SELECT",""))_"^1:"_VALMCNT
S XQORM("??")="D HELP^VALM2,HDR^PSOERPT0"
Q
;
HDR ; ListMan Header Code
N POS,LINE1,LINE2
S LINE1="eRx PATIENT: "_IOINHI_$E($$GET1^DIQ(52.46,EPATIEN,.01),1,40)_IOINORM
S $E(LINE1,63)="SEX: "_IOINHI_$$GET1^DIQ(52.46,EPATIEN,.07,"I")_IOINORM
D INSTR^VALM1("DOB: "_IOINHI_$$FMTE^XLFDT($$GET1^DIQ(52.46,EPATIEN,.08,"I"),"2Z")_"("_($$FMDIFF^XLFDT(DT,$$GET1^DIQ(52.46,EPATIEN,.08,"I"))\365)_")"_IOINORM,63,2)
S LINE2="LOOK BACK DAYS: "_IOINHI_PSOLKBKD_IOINORM
S $E(LINE2,38)="STATUS: "_IOINHI_$S(PSOALLST:"ALL",1:"ACTIONABLE")_IOINORM
D INSTR^VALM1("SSN: "_IOINHI_$$SSN^PSOERUT($$GET1^DIQ(52.46,EPATIEN,1.4))_IOINORM,54,3)
D INSTR^VALM1(IORVON_"MATCHING "_IOINORM,72,3)
;
I $G(NPALERT),$D(^XUSEC("PSO ERX WORKLOAD TECH",DUZ)) D
. N POS S POS=22 I $G(VALM("LINES")) S POS=VALM("LINES")+5
. D INSTR^VALM1(IOBON_IORVON_"You must complete all prescriptions before proceeding"_IOBOFF,10,POS) W $C(7)
. S NPALERT=0
;
K VALMHDR S VALMHDR(1)=LINE1,VALMHDR(2)=LINE2
D SETHDR^PSOERPT1()
Q
;
INIT ;Populates the Body section for ListMan
K PSOIEN,^TMP("PSOERPT0",$J),^TMP("PSOERPTS",$J)
D SETSORT^PSOERPT1(PSOSRTBY),SETLINE
S 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,TOTAL,I,X,X1,ORDCNT,LBL,LN,GROUP,QTYL,ORNUM1,ERXIEN1,SORTORD
N X,POS,HIGHLN,GRPLN,UNDLN,PTMTCHLN,PRMTCHLN,PRVALLN,DRMTCHLN
K ^TMP("PSOERPT0",$J)
I '$D(^TMP("PSOERPTS",$J)) D Q
. F I=1:1:6 S ^TMP("PSOERPT0",$J,I,0)=""
. S ^TMP("PSOERPT0",$J,7,0)=" No prescriptions found for this patient."
. S VALMCNT=1
;
;Resetting list to NORMAL video attributes
D RESET^PSOERUT0()
;
;Building the list (line by line)
S (GROUP,SORT,SEQ)="",LINE=0,SORTORD=$S(PSORDER="A":1,1:-1)
F S GROUP=$O(^TMP("PSOERPTS",$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("PSOERPT0",$J,LINE,0)=X,GRPLN(LINE)=LBL
. F S SORT=$O(^TMP("PSOERPTS",$J,GROUP,SORT),SORTORD) Q:SORT="" D
. . S Z=$G(^TMP("PSOERPTS",$J,GROUP,SORT)),SEQ=SEQ+1
. . S ERXIEN=+$G(^TMP("PSOERPTS",$J,GROUP,SORT,"ERXIEN"))
. . S X1=SEQ_$S($$GET1^DIQ(52.49,ERXIEN,95.1,"I"):"]",1:".")
. . S $E(X1,5)=$$GET1^DIQ(52.49,ERXIEN,.01) I '$G(PSODETDP) S $E(X1,19)=$E($P(Z,"^"),1,22)
. . ; Abbreviating REM## status to R## for MbM sites (VA Sites only have RM)
. . I $G(MBMSITE),$E($P(Z,"^",4),1,3)="REM" S $P(Z,"^",4)="R"_$E($P(Z,"^",4),4,9)
. . S $E(X1,42)=$P(Z,"^",2),$E(X1,59)=$P(Z,"^",3),$E(X1,68)=$P(Z,"^",4)
. . S $E(X1,72)=$P(Z,"^",5),$E(X1,75)=$P(Z,"^",6),$E(X1,78)=$P(Z,"^",7)
. . S LINE=LINE+1,^TMP("PSOERPT0",$J,LINE,0)=X1,^TMP("PSOERPT0",$J,SEQ,"ERXIEN")=ERXIEN
. . I $G(^TMP("PSOERPTS",$J,GROUP,SORT,"PATAM")) S PTMTCHLN(LINE)=1
. . I $G(^TMP("PSOERPTS",$J,GROUP,SORT,"PROAM")) S PRMTCHLN(LINE)=1
. . I $G(^TMP("PSOERPTS",$J,GROUP,SORT,"PROAV")) S PRVALLN(LINE)=1
. . I $G(^TMP("PSOERPTS",$J,GROUP,SORT,"DRUAM")) S DRMTCHLN(LINE)=1
. . I $G(PSODETDP) D SETDET(ERXIEN,.LINE,"PSOERPT0")
;
;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
;
SETDET(ERXIEN,LINE,NMPSC) ; Set the Details lines
;Input: ERXIEN - Pointer to the eRx HOLDING QUEUE (#52.49)
; LINE - Current Line on the List
; NMSPC - Namespace for the ^TMP global (Listman)
N L,X,DIWL,DIWR,Z
K ^UTILITY($J,"W") S Z=$G(^PS(52.49,ERXIEN,5))
S X=" eRx Drug: "_$$GET1^DIQ(52.49,ERXIEN,3.1,"E")_" "_$P($$ERXDRSCH^PSOERXUT(ERXIEN),"^",2)
S LINE=LINE+1,^TMP(NMPSC,$J,LINE,0)=X,HIGHLN(LINE)=""
S X=" eRx Qty: "_$P(Z,"^")
S $E(X,29)="eRx # of Refills: "_$P(Z,"^",6)
S $E(X,57)=" eRx Days Supply: "_$P(Z,"^",5)
S LINE=LINE+1,^TMP(NMPSC,$J,LINE,0)=X,HIGHLN(LINE)=""
S X=$$ERXSIG^PSOERXUT(ERXIEN),DIWL=1,DIWR=71 D ^DIWP
F L=1:1 Q:'$D(^UTILITY($J,"W",1,L)) D
. S X="" S:L=1 $E(X,5)="SIG:" S $E(X,10)=^UTILITY($J,"W",1,L,0)
. S LINE=LINE+1,^TMP(NMPSC,$J,LINE,0)=X,HIGHLN(LINE)=""
Q
;
ID ;Sort by eRx ID
D SORT("ID")
Q
DR ;Sort by Drug Name
D SORT("DR")
Q
PR ;Sort by Provider Name
D SORT("PR")
Q
RE ;Sort by Received Date
D SORT("RE")
Q
STA ;Sort by Status
D SORT("STA")
Q
PAM ;Sort by Patient Match
D SORT("PAM")
Q
PRM ;Sort by Provider Match
D SORT("PRM")
Q
DRM ;Sort by Drug Match
D SORT("DRM")
Q
ALL ;Sort by All Matches
D SORT("ALL")
Q
;
GS ;Group by Status
W ?52,"Please wait..." S PSOSTSGP=$S($G(PSOSTSGP):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
;
IAS ;Include All Status Switch
W ?52,"Please wait..." S PSOALLST=$S($G(PSOALLST):0,1:1),LINE=0 D REF
I 'PSOALLST S VALMBG=1
Q
;
CS ;Group/Un-group Controlled Substances
W ?52,"Please wait..." S PSOCSGRP=$S($G(PSOCSGRP):0,1:1) D REF
Q
;
CV ;Change View
D EN^PSOERPR2 D REF S VALMBG=1
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.352,1",DIR("B")=PSOLKBKD
D ^DIR I $D(DIRUT)!$D(DIROUT) Q
S PSOLKBKD=Y,RESETLBD=0 D REF S VALMBG=1
Q
;
REF ;Screen Refresh
W ?65,"Please wait..." D INIT,HDR S VALMBCK="R"
Q
;
BH ; Batch Hold Hidden action
N SEL,DIR,ERXLST,ERXIEN,LINE,ERXSTAT,MSGTYPE,HDCODE,HDCOMM,DIE,DR,XX,X,Y,SEQ
S VALMBCK="R" D FULL^VALM1
;
K DIR S DIR("A")="Select Range (1-"_+$G(VALMCNT)_"): "
S DIR(0)="LA^1:"_+$G(VALMCNT) W !
D ^DIR I $D(DIRUT)!$D(DIROUT) Q
D ERXLST^PSOERPT1(Y,.ERXLST)
I '$D(ERXLST) D G BH
. W !!,"Invalid Range. Please select a range of entries between 1 and "_$G(VALMCNT)_".",$C(7)
;
I '$$HOLDELIG^PSOERPT2(.ERXLST) D Q
. W !!,"UNABLE TO BATCH HOLD: At least one eRx entry cannot be put on HOLD.",$C(7)
. D LSTERXS^PSOERPT1(.ERXLST,1,1)
. W ! K DIR D PAUSE^VALM1
;
D LSTERXS^PSOERPT1(.ERXLST,0,1)
;
I '$$OPACCESS^PSOERPT1("PSO ERX HOLD",DUZ,.ERXLST) D Q
. W !!,"UNABLE TO BATCH HOLD: Either you do not have the appropriate security keys"
. W !?22,"or one or more records cannot be put on HOLD",$C(7)
. K DIR D PAUSE^VALM1
;
W ! S HDCODE=$$HDIR^PSOERXH1(1)
I 'HDCODE D Q
. W "Hold Reason required. eRx not placed in a 'Hold' status."
;
W ! K DIR S DIR(0)="52.4919,1",DIR("A")="Additional Comments (Optional)" D ^DIR I Y="^" Q
S HDCOMM=Y
;
S DIR("A",2)="",DIR("A")="Confirm Batch Hold",DIR(0)="Y",DIR("B")="N"
D ^DIR I 'Y!$D(DIRUT)!$D(DIROUT) Q
;
W !!,"Updating..."
S SEQ=0 F S SEQ=$O(ERXLST(SEQ)) Q:'SEQ D
. S ERXIEN=ERXLST(SEQ)
. D UPDSTAT^PSOERXU1(ERXIEN,$$GET1^DIQ(52.45,HDCODE,.01),HDCOMM)
H .5 W "done" H 1
D REF
Q
;
BU ; Batch Un-Hold Hidden action
N SEL,DIR,ERXLST,ERXIEN,LINE,ERXSTAT,MSGTYPE,HDCODE,HDCOMM,DIE,DR,XX,UHCOMM,SEQ,UNHDSTAT
S VALMBCK="R" D FULL^VALM1
;
K DIR S DIR("A")="Select Range (1-"_+$G(VALMCNT)_"): "
S DIR(0)="LA^1:"_+$G(VALMCNT) W !
D ^DIR I $D(DIRUT)!$D(DIROUT) Q
D ERXLST^PSOERPT1(Y,.ERXLST)
I '$D(ERXLST) D G BH
. W !!,"Invalid Range. Please select a range of entries between 1 and "_$G(VALMCNT)_".",$C(7)
;
I '$$UNHDELIG^PSOERPT2(.ERXLST) D Q
. W !!,"UNABLE TO BATCH UN-HOLD: At least one eRx entry cannot be removed from HOLD.",$C(7)
. w ! D LSTERXS^PSOERPT1(.ERXLST,1,1)
. W ! K DIR D PAUSE^VALM1
;
D LSTERXS^PSOERPT1(.ERXLST,0,1)
;
I '$$OPACCESS^PSOERPT1("PSO ERX UNHOLD",DUZ,.ERXLST) D Q
. W !!,"UNABLE TO BATCH UN-HOLD: Either you do not have the appropriate security keys"
. W !?25,"or one or more records cannot be removed from HOLD",$C(7) K DIR D PAUSE^VALM1
;
; Un-Hold Comments
W ! K DIR S DIR(0)="52.4919,1",DIR("A")="Additional Comments (Optional)" D ^DIR K DIR
I Y="^" Q
S UHCOMM=$G(Y)
;
S DIR("A",2)="",DIR("A")="Confirm Batch Un-Hold",DIR(0)="Y",DIR("B")="N"
D ^DIR I 'Y!$D(DIRUT)!$D(DIROUT) Q
;
W !!,"Updating..."
S SEQ=0 F S SEQ=$O(ERXLST(SEQ)) Q:'SEQ D
. S ERXIEN=ERXLST(SEQ)
. S UNHDSTAT=$$UNHDSTAT^PSOERPT2(ERXIEN)
. D UPDSTAT^PSOERXU1(ERXIEN,UNHDSTAT,UHCOMM)
H .5 W "done" H 1
D REF
Q
;
SEL ;Process selection of one entry
N PSOSEL,ERXIEN
S VALMBCK="R"
S PSOSEL=+$P(XQORNOD(0),"=",2) I 'PSOSEL S VALMSG="Invalid selection!" Q
S ERXIEN=$G(^TMP("PSOERPT0",$J,PSOSEL,"ERXIEN")) I 'ERXIEN S VALMSG="Invalid selection!",VALMBCK="R" Q
; - Entering the eRx Record
D ; Protecting variables
. D FULL^VALM1
. N EPATIEN,DIR,ERXLOCK S EPATIEN=$$GETPAT^PSOERXU5(ERXIEN)
. S ERXLOCK=$$L^PSOERX1A(EPATIEN,1)
. I 'ERXLOCK S DIR(0)="E" D ^DIR K DIR Q
. D EN^PSOERX1(ERXIEN)
. ;Not using D UL^PSOERX1A on purpose as it will kill the ^XTMP entry
. L -^XTMP("PSOERXLOCK",EPATIEN)
D REF
Q
;
NP ; Automatically Selects the Next Patient
N ERXPTIEN,SUCCESS,NEXTPAT
S VALMBCK="Q",NPALERT=0
; Prevents MbM users from moving to the next patient if current patient still has New eRx recrods
I $G(PSOSTFLT)="WP",$D(^XUSEC("PSO ERX WORKLOAD TECH",DUZ)),$$HASACTRX^PSOERPT2(EPATIEN) D Q
. I PSOLKBKD'=+$$GET1^DIQ(59,PSOSITE,10.2),$$GET1^DIQ(59,PSOSITE,10.2)'="" S PSOLKBKD=+$$GET1^DIQ(59,PSOSITE,10.2) D INIT,HDR
. S NPALERT=1,VALMBCK="R"
W ?50,"Loading Next Patient..."
S (SUCCESS)=0,NEXTPAT=EPATIEN
F S ERXPTIEN=$$NEXTPAT^PSOERPC1(NEXTPAT) Q:'ERXPTIEN D I SUCCESS Q
. ; - Trying to Lock new eRx Patient
. I '$$LOCK^PSOERPC1(ERXPTIEN) S NEXTPAT=ERXPTIEN Q
. S SUCCESS=1
I 'SUCCESS!'ERXPTIEN Q
; - Unlocking Current eRx Patient
D UL^PSOERX1A(EPATIEN)
S EPATIEN=ERXPTIEN
D REF S VALMBG=1
Q
;
EXIT ; - Exit point
; - Unlocking Current eRx Patient
D UL^PSOERX1A(EPATIEN)
K ^TMP("PSOERPT0",$J),^TMP("PSOERPTS",$J)
Q
;
HELP Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOERPT0 11250 printed Sep 23, 2025@20:04:12 Page 2
PSOERPT0 ;BIRM/MFR - eRx Single Patient Queue - ListManager ; 12/10/22 9:53am
+1 ;;7.0;OUTPATIENT PHARMACY;**700,746,770**;DEC 1997;Build 145
+2 ;
EN ;Menu option entry point
+1 NEW PSNPINST,PSOSRTBY,PSORDER,PSODETDP,PSOSTSGP,PSOSTORD,PSORDCNT,PSOSTSEQ,PSORDSEQ,PSOCHNG
+2 NEW GRPLN,DIC,Y,DFN,HIGHLN,LASTLINE,VALMCNT,NPALERT,PSOCSGRP,PSOIEN,ERXIEN
+3 ;
+4 ;Division selection
+5 IF '$GET(PSOSITE)
DO FULL^VALM1
DO ^PSOLSET
IF '$DATA(PSOPAR)
WRITE $CHAR(7),!!,"Pharmacy Division Must be Selected!",!
GOTO EXIT
+6 SET PSNPINST=$$GET1^DIQ(59,PSOSITE,101,"I")
+7 ;
+8 ;Patient selection
+9 WRITE !!
SET DIC=52.46
SET DIC(0)="QEAM"
SET DIC("A")="ERX PATIENT: "
+10 DO ^DIC
if Y<0
GOTO EXIT
SET EPATIEN=+Y
+11 DO LST(EPATIEN)
+12 GOTO EXIT
+13 QUIT
+14 ;
LST(EPATIEN) ; ListMan Action Entry point
+1 ;Input: EPATIEN - Pointer to the eRx PATIENT (#52.46)
+2 ; Loading Division/User preferences
+3 DO LOAD^PSOERPR2
+4 WRITE !,"Please wait..."
+5 DO EN^VALM("PSO ERX SINGLE PATIENT QUEUE")
+6 ;
+7 GOTO EXIT
+8 ;
LMHDR ; Menu Protocol Header Code
+1 DO SHOW^VALM
DO HDR
+2 if ($GET(PSOSTFLT)="WP")
SET XQORM("B")="NP"
+3 SET XQORM("#")=$ORDER(^ORD(101,"B","PSO ERX SINGLE PATIENT SELECT",""))_"^1:"_VALMCNT
+4 SET XQORM("??")="D HELP^VALM2,HDR^PSOERPT0"
+5 QUIT
+6 ;
HDR ; ListMan Header Code
+1 NEW POS,LINE1,LINE2
+2 SET LINE1="eRx PATIENT: "_IOINHI_$EXTRACT($$GET1^DIQ(52.46,EPATIEN,.01),1,40)_IOINORM
+3 SET $EXTRACT(LINE1,63)="SEX: "_IOINHI_$$GET1^DIQ(52.46,EPATIEN,.07,"I")_IOINORM
+4 DO INSTR^VALM1("DOB: "_IOINHI_$$FMTE^XLFDT($$GET1^DIQ(52.46,EPATIEN,.08,"I"),"2Z")_"("_($$FMDIFF^XLFDT(DT,$$GET1^DIQ(52.46,EPATIEN,.08,"I"))\365)_")"_IOINORM,63,2)
+5 SET LINE2="LOOK BACK DAYS: "_IOINHI_PSOLKBKD_IOINORM
+6 SET $EXTRACT(LINE2,38)="STATUS: "_IOINHI_$SELECT(PSOALLST:"ALL",1:"ACTIONABLE")_IOINORM
+7 DO INSTR^VALM1("SSN: "_IOINHI_$$SSN^PSOERUT($$GET1^DIQ(52.46,EPATIEN,1.4))_IOINORM,54,3)
+8 DO INSTR^VALM1(IORVON_"MATCHING "_IOINORM,72,3)
+9 ;
+10 IF $GET(NPALERT)
IF $DATA(^XUSEC("PSO ERX WORKLOAD TECH",DUZ))
Begin DoDot:1
+11 NEW POS
SET POS=22
IF $GET(VALM("LINES"))
SET POS=VALM("LINES")+5
+12 DO INSTR^VALM1(IOBON_IORVON_"You must complete all prescriptions before proceeding"_IOBOFF,10,POS)
WRITE $CHAR(7)
+13 SET NPALERT=0
End DoDot:1
+14 ;
+15 KILL VALMHDR
SET VALMHDR(1)=LINE1
SET VALMHDR(2)=LINE2
+16 DO SETHDR^PSOERPT1()
+17 QUIT
+18 ;
INIT ;Populates the Body section for ListMan
+1 KILL PSOIEN,^TMP("PSOERPT0",$JOB),^TMP("PSOERPTS",$JOB)
+2 DO SETSORT^PSOERPT1(PSOSRTBY)
DO SETLINE
+3 SET VALMSG="Select the entry # to view or ?? for more actions"
+4 QUIT
+5 ;
SETLINE ;Sets the line to be displayed in ListMan
+1 NEW SORT,TYPE,STS,SUB,SEQ,LINE,Z,TOTAL,I,X,X1,ORDCNT,LBL,LN,GROUP,QTYL,ORNUM1,ERXIEN1,SORTORD
+2 NEW X,POS,HIGHLN,GRPLN,UNDLN,PTMTCHLN,PRMTCHLN,PRVALLN,DRMTCHLN
+3 KILL ^TMP("PSOERPT0",$JOB)
+4 IF '$DATA(^TMP("PSOERPTS",$JOB))
Begin DoDot:1
+5 FOR I=1:1:6
SET ^TMP("PSOERPT0",$JOB,I,0)=""
+6 SET ^TMP("PSOERPT0",$JOB,7,0)=" No prescriptions found for this patient."
+7 SET VALMCNT=1
End DoDot:1
QUIT
+8 ;
+9 ;Resetting list to NORMAL video attributes
+10 DO RESET^PSOERUT0()
+11 ;
+12 ;Building the list (line by line)
+13 SET (GROUP,SORT,SEQ)=""
SET LINE=0
SET SORTORD=$SELECT(PSORDER="A":1,1:-1)
+14 FOR
SET GROUP=$ORDER(^TMP("PSOERPTS",$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("PSOERPT0",$JOB,LINE,0)=X
SET GRPLN(LINE)=LBL
End DoDot:2
+20 FOR
SET SORT=$ORDER(^TMP("PSOERPTS",$JOB,GROUP,SORT),SORTORD)
if SORT=""
QUIT
Begin DoDot:2
+21 SET Z=$GET(^TMP("PSOERPTS",$JOB,GROUP,SORT))
SET SEQ=SEQ+1
+22 SET ERXIEN=+$GET(^TMP("PSOERPTS",$JOB,GROUP,SORT,"ERXIEN"))
+23 SET X1=SEQ_$SELECT($$GET1^DIQ(52.49,ERXIEN,95.1,"I"):"]",1:".")
+24 SET $EXTRACT(X1,5)=$$GET1^DIQ(52.49,ERXIEN,.01)
IF '$GET(PSODETDP)
SET $EXTRACT(X1,19)=$EXTRACT($PIECE(Z,"^"),1,22)
+25 ; Abbreviating REM## status to R## for MbM sites (VA Sites only have RM)
+26 IF $GET(MBMSITE)
IF $EXTRACT($PIECE(Z,"^",4),1,3)="REM"
SET $PIECE(Z,"^",4)="R"_$EXTRACT($PIECE(Z,"^",4),4,9)
+27 SET $EXTRACT(X1,42)=$PIECE(Z,"^",2)
SET $EXTRACT(X1,59)=$PIECE(Z,"^",3)
SET $EXTRACT(X1,68)=$PIECE(Z,"^",4)
+28 SET $EXTRACT(X1,72)=$PIECE(Z,"^",5)
SET $EXTRACT(X1,75)=$PIECE(Z,"^",6)
SET $EXTRACT(X1,78)=$PIECE(Z,"^",7)
+29 SET LINE=LINE+1
SET ^TMP("PSOERPT0",$JOB,LINE,0)=X1
SET ^TMP("PSOERPT0",$JOB,SEQ,"ERXIEN")=ERXIEN
+30 IF $GET(^TMP("PSOERPTS",$JOB,GROUP,SORT,"PATAM"))
SET PTMTCHLN(LINE)=1
+31 IF $GET(^TMP("PSOERPTS",$JOB,GROUP,SORT,"PROAM"))
SET PRMTCHLN(LINE)=1
+32 IF $GET(^TMP("PSOERPTS",$JOB,GROUP,SORT,"PROAV"))
SET PRVALLN(LINE)=1
+33 IF $GET(^TMP("PSOERPTS",$JOB,GROUP,SORT,"DRUAM"))
SET DRMTCHLN(LINE)=1
+34 IF $GET(PSODETDP)
DO SETDET(ERXIEN,.LINE,"PSOERPT0")
End DoDot:2
End DoDot:1
+35 ;
+36 ;Saving NORMAL video attributes to be reset later
+37 IF LINE>$GET(LASTLINE)
Begin DoDot:1
+38 FOR I=($GET(LASTLINE)+1):1:LINE
DO SAVE^VALM10(I)
+39 SET LASTLINE=LINE
End DoDot:1
+40 DO VIDEO^PSOERPT1()
+41 SET VALMCNT=+$GET(LINE)
DO RV^PSOPMP1
+42 QUIT
+43 ;
SETDET(ERXIEN,LINE,NMPSC) ; Set the Details lines
+1 ;Input: ERXIEN - Pointer to the eRx HOLDING QUEUE (#52.49)
+2 ; LINE - Current Line on the List
+3 ; NMSPC - Namespace for the ^TMP global (Listman)
+4 NEW L,X,DIWL,DIWR,Z
+5 KILL ^UTILITY($JOB,"W")
SET Z=$GET(^PS(52.49,ERXIEN,5))
+6 SET X=" eRx Drug: "_$$GET1^DIQ(52.49,ERXIEN,3.1,"E")_" "_$PIECE($$ERXDRSCH^PSOERXUT(ERXIEN),"^",2)
+7 SET LINE=LINE+1
SET ^TMP(NMPSC,$JOB,LINE,0)=X
SET HIGHLN(LINE)=""
+8 SET X=" eRx Qty: "_$PIECE(Z,"^")
+9 SET $EXTRACT(X,29)="eRx # of Refills: "_$PIECE(Z,"^",6)
+10 SET $EXTRACT(X,57)=" eRx Days Supply: "_$PIECE(Z,"^",5)
+11 SET LINE=LINE+1
SET ^TMP(NMPSC,$JOB,LINE,0)=X
SET HIGHLN(LINE)=""
+12 SET X=$$ERXSIG^PSOERXUT(ERXIEN)
SET DIWL=1
SET DIWR=71
DO ^DIWP
+13 FOR L=1:1
if '$DATA(^UTILITY($JOB,"W",1,L))
QUIT
Begin DoDot:1
+14 SET X=""
if L=1
SET $EXTRACT(X,5)="SIG:"
SET $EXTRACT(X,10)=^UTILITY($JOB,"W",1,L,0)
+15 SET LINE=LINE+1
SET ^TMP(NMPSC,$JOB,LINE,0)=X
SET HIGHLN(LINE)=""
End DoDot:1
+16 QUIT
+17 ;
ID ;Sort by eRx ID
+1 DO SORT("ID")
+2 QUIT
DR ;Sort by Drug Name
+1 DO SORT("DR")
+2 QUIT
PR ;Sort by Provider Name
+1 DO SORT("PR")
+2 QUIT
RE ;Sort by Received Date
+1 DO SORT("RE")
+2 QUIT
STA ;Sort by Status
+1 DO SORT("STA")
+2 QUIT
PAM ;Sort by Patient Match
+1 DO SORT("PAM")
+2 QUIT
PRM ;Sort by Provider Match
+1 DO SORT("PRM")
+2 QUIT
DRM ;Sort by Drug Match
+1 DO SORT("DRM")
+2 QUIT
ALL ;Sort by All Matches
+1 DO SORT("ALL")
+2 QUIT
+3 ;
GS ;Group by Status
+1 WRITE ?52,"Please wait..."
SET PSOSTSGP=$SELECT($GET(PSOSTSGP):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 ;
IAS ;Include All Status Switch
+1 WRITE ?52,"Please wait..."
SET PSOALLST=$SELECT($GET(PSOALLST):0,1:1)
SET LINE=0
DO REF
+2 IF 'PSOALLST
SET VALMBG=1
+3 QUIT
+4 ;
CS ;Group/Un-group Controlled Substances
+1 WRITE ?52,"Please wait..."
SET PSOCSGRP=$SELECT($GET(PSOCSGRP):0,1:1)
DO REF
+2 QUIT
+3 ;
CV ;Change View
+1 DO EN^PSOERPR2
DO REF
SET VALMBG=1
+2 QUIT
+3 ;
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.352,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 ;
REF ;Screen Refresh
+1 WRITE ?65,"Please wait..."
DO INIT
DO HDR
SET VALMBCK="R"
+2 QUIT
+3 ;
BH ; Batch Hold Hidden action
+1 NEW SEL,DIR,ERXLST,ERXIEN,LINE,ERXSTAT,MSGTYPE,HDCODE,HDCOMM,DIE,DR,XX,X,Y,SEQ
+2 SET VALMBCK="R"
DO FULL^VALM1
+3 ;
+4 KILL DIR
SET DIR("A")="Select Range (1-"_+$GET(VALMCNT)_"): "
+5 SET DIR(0)="LA^1:"_+$GET(VALMCNT)
WRITE !
+6 DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)
QUIT
+7 DO ERXLST^PSOERPT1(Y,.ERXLST)
+8 IF '$DATA(ERXLST)
Begin DoDot:1
+9 WRITE !!,"Invalid Range. Please select a range of entries between 1 and "_$GET(VALMCNT)_".",$CHAR(7)
End DoDot:1
GOTO BH
+10 ;
+11 IF '$$HOLDELIG^PSOERPT2(.ERXLST)
Begin DoDot:1
+12 WRITE !!,"UNABLE TO BATCH HOLD: At least one eRx entry cannot be put on HOLD.",$CHAR(7)
+13 DO LSTERXS^PSOERPT1(.ERXLST,1,1)
+14 WRITE !
KILL DIR
DO PAUSE^VALM1
End DoDot:1
QUIT
+15 ;
+16 DO LSTERXS^PSOERPT1(.ERXLST,0,1)
+17 ;
+18 IF '$$OPACCESS^PSOERPT1("PSO ERX HOLD",DUZ,.ERXLST)
Begin DoDot:1
+19 WRITE !!,"UNABLE TO BATCH HOLD: Either you do not have the appropriate security keys"
+20 WRITE !?22,"or one or more records cannot be put on HOLD",$CHAR(7)
+21 KILL DIR
DO PAUSE^VALM1
End DoDot:1
QUIT
+22 ;
+23 WRITE !
SET HDCODE=$$HDIR^PSOERXH1(1)
+24 IF 'HDCODE
Begin DoDot:1
+25 WRITE "Hold Reason required. eRx not placed in a 'Hold' status."
End DoDot:1
QUIT
+26 ;
+27 WRITE !
KILL DIR
SET DIR(0)="52.4919,1"
SET DIR("A")="Additional Comments (Optional)"
DO ^DIR
IF Y="^"
QUIT
+28 SET HDCOMM=Y
+29 ;
+30 SET DIR("A",2)=""
SET DIR("A")="Confirm Batch Hold"
SET DIR(0)="Y"
SET DIR("B")="N"
+31 DO ^DIR
IF 'Y!$DATA(DIRUT)!$DATA(DIROUT)
QUIT
+32 ;
+33 WRITE !!,"Updating..."
+34 SET SEQ=0
FOR
SET SEQ=$ORDER(ERXLST(SEQ))
if 'SEQ
QUIT
Begin DoDot:1
+35 SET ERXIEN=ERXLST(SEQ)
+36 DO UPDSTAT^PSOERXU1(ERXIEN,$$GET1^DIQ(52.45,HDCODE,.01),HDCOMM)
End DoDot:1
+37 HANG .5
WRITE "done"
HANG 1
+38 DO REF
+39 QUIT
+40 ;
BU ; Batch Un-Hold Hidden action
+1 NEW SEL,DIR,ERXLST,ERXIEN,LINE,ERXSTAT,MSGTYPE,HDCODE,HDCOMM,DIE,DR,XX,UHCOMM,SEQ,UNHDSTAT
+2 SET VALMBCK="R"
DO FULL^VALM1
+3 ;
+4 KILL DIR
SET DIR("A")="Select Range (1-"_+$GET(VALMCNT)_"): "
+5 SET DIR(0)="LA^1:"_+$GET(VALMCNT)
WRITE !
+6 DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)
QUIT
+7 DO ERXLST^PSOERPT1(Y,.ERXLST)
+8 IF '$DATA(ERXLST)
Begin DoDot:1
+9 WRITE !!,"Invalid Range. Please select a range of entries between 1 and "_$GET(VALMCNT)_".",$CHAR(7)
End DoDot:1
GOTO BH
+10 ;
+11 IF '$$UNHDELIG^PSOERPT2(.ERXLST)
Begin DoDot:1
+12 WRITE !!,"UNABLE TO BATCH UN-HOLD: At least one eRx entry cannot be removed from HOLD.",$CHAR(7)
+13 WRITE !
DO LSTERXS^PSOERPT1(.ERXLST,1,1)
+14 WRITE !
KILL DIR
DO PAUSE^VALM1
End DoDot:1
QUIT
+15 ;
+16 DO LSTERXS^PSOERPT1(.ERXLST,0,1)
+17 ;
+18 IF '$$OPACCESS^PSOERPT1("PSO ERX UNHOLD",DUZ,.ERXLST)
Begin DoDot:1
+19 WRITE !!,"UNABLE TO BATCH UN-HOLD: Either you do not have the appropriate security keys"
+20 WRITE !?25,"or one or more records cannot be removed from HOLD",$CHAR(7)
KILL DIR
DO PAUSE^VALM1
End DoDot:1
QUIT
+21 ;
+22 ; Un-Hold Comments
+23 WRITE !
KILL DIR
SET DIR(0)="52.4919,1"
SET DIR("A")="Additional Comments (Optional)"
DO ^DIR
KILL DIR
+24 IF Y="^"
QUIT
+25 SET UHCOMM=$GET(Y)
+26 ;
+27 SET DIR("A",2)=""
SET DIR("A")="Confirm Batch Un-Hold"
SET DIR(0)="Y"
SET DIR("B")="N"
+28 DO ^DIR
IF 'Y!$DATA(DIRUT)!$DATA(DIROUT)
QUIT
+29 ;
+30 WRITE !!,"Updating..."
+31 SET SEQ=0
FOR
SET SEQ=$ORDER(ERXLST(SEQ))
if 'SEQ
QUIT
Begin DoDot:1
+32 SET ERXIEN=ERXLST(SEQ)
+33 SET UNHDSTAT=$$UNHDSTAT^PSOERPT2(ERXIEN)
+34 DO UPDSTAT^PSOERXU1(ERXIEN,UNHDSTAT,UHCOMM)
End DoDot:1
+35 HANG .5
WRITE "done"
HANG 1
+36 DO REF
+37 QUIT
+38 ;
SEL ;Process selection of one entry
+1 NEW PSOSEL,ERXIEN
+2 SET VALMBCK="R"
+3 SET PSOSEL=+$PIECE(XQORNOD(0),"=",2)
IF 'PSOSEL
SET VALMSG="Invalid selection!"
QUIT
+4 SET ERXIEN=$GET(^TMP("PSOERPT0",$JOB,PSOSEL,"ERXIEN"))
IF 'ERXIEN
SET VALMSG="Invalid selection!"
SET VALMBCK="R"
QUIT
+5 ; - Entering the eRx Record
+6 ; Protecting variables
Begin DoDot:1
+7 DO FULL^VALM1
+8 NEW EPATIEN,DIR,ERXLOCK
SET EPATIEN=$$GETPAT^PSOERXU5(ERXIEN)
+9 SET ERXLOCK=$$L^PSOERX1A(EPATIEN,1)
+10 IF 'ERXLOCK
SET DIR(0)="E"
DO ^DIR
KILL DIR
QUIT
+11 DO EN^PSOERX1(ERXIEN)
+12 ;Not using D UL^PSOERX1A on purpose as it will kill the ^XTMP entry
+13 LOCK -^XTMP("PSOERXLOCK",EPATIEN)
End DoDot:1
+14 DO REF
+15 QUIT
+16 ;
NP ; Automatically Selects the Next Patient
+1 NEW ERXPTIEN,SUCCESS,NEXTPAT
+2 SET VALMBCK="Q"
SET NPALERT=0
+3 ; Prevents MbM users from moving to the next patient if current patient still has New eRx recrods
+4 IF $GET(PSOSTFLT)="WP"
IF $DATA(^XUSEC("PSO ERX WORKLOAD TECH",DUZ))
IF $$HASACTRX^PSOERPT2(EPATIEN)
Begin DoDot:1
+5 IF PSOLKBKD'=+$$GET1^DIQ(59,PSOSITE,10.2)
IF $$GET1^DIQ(59,PSOSITE,10.2)'=""
SET PSOLKBKD=+$$GET1^DIQ(59,PSOSITE,10.2)
DO INIT
DO HDR
+6 SET NPALERT=1
SET VALMBCK="R"
End DoDot:1
QUIT
+7 WRITE ?50,"Loading Next Patient..."
+8 SET (SUCCESS)=0
SET NEXTPAT=EPATIEN
+9 FOR
SET ERXPTIEN=$$NEXTPAT^PSOERPC1(NEXTPAT)
if 'ERXPTIEN
QUIT
Begin DoDot:1
+10 ; - Trying to Lock new eRx Patient
+11 IF '$$LOCK^PSOERPC1(ERXPTIEN)
SET NEXTPAT=ERXPTIEN
QUIT
+12 SET SUCCESS=1
End DoDot:1
IF SUCCESS
QUIT
+13 IF 'SUCCESS!'ERXPTIEN
QUIT
+14 ; - Unlocking Current eRx Patient
+15 DO UL^PSOERX1A(EPATIEN)
+16 SET EPATIEN=ERXPTIEN
+17 DO REF
SET VALMBG=1
+18 QUIT
+19 ;
EXIT ; - Exit point
+1 ; - Unlocking Current eRx Patient
+2 DO UL^PSOERX1A(EPATIEN)
+3 KILL ^TMP("PSOERPT0",$JOB),^TMP("PSOERPTS",$JOB)
+4 QUIT
+5 ;
HELP QUIT
