PSOERPC0 ;BIRM/MFR - All Patients (Patient Centric) eRx Queue - ListManager ;09/28/22
;;7.0;OUTPATIENT PHARMACY;**700,750**;DEC 1997;Build 6
;
;Menu option entry point
N MBMSITE,PSOSTFLT,PSOHDSTS,PSOCCRST,PSOSRTBY,PSORDER,PSOCSGRP,PSOLKBKD,PSOCSERX,PSOCSSCH,PSOCSGRP,PSOMAXQS
N GRPLN,DIC,DFN,GRPLN,HIGHLN,LASTLINE,VALMCNT,PTMTCHLN,PRMTCHLN,DRMTCHLN,PATFLTR,VPATFLTR,DOBFLTR,MATFLTR,PSONEXTP
N DIR,Y,DIRUT,DIROUT,CODE,DIRUT,DTOUT,PSOVIEW,PSOCSSCH,PSOCSERX,PSOQUIT,REDTFLTR,PRVFLTR,DRGFLTR
N RESETLBD,PSOCLNC,PSORFRSH,IDX
;
; MBMSITE indicates whether it's an MbM site or not, RESETLBD indicates whether the Look Back Days should be reset
S MBMSITE=$S($$GET1^DIQ(59.7,1,102,"I")="MBM":1,1:0),RESETLBD=1
;
;Review/Clean-up Locks (e.g.,Session crased and ^XTMP global remained)
D REVLOCKS^PSOERPC2
;
;Division Selection
I '$G(PSOSITE) D ^PSOLSET I '$D(PSOPAR) W $C(7),!!,"Pharmacy Division Must be Selected!",! G EXIT
S PSNPINST=$$GET1^DIQ(59,PSOSITE,101,"I")
;
;Clinic Selection (MbM Sites Only)
S PSOCLNC=+$$GET1^DIQ(59,PSOSITE,10,"I")
I $G(MBMSITE) D I $G(PSOQUIT) G EXIT
. W ! K DIC
. S DIC(0)="AEMQ",DIC=44,DIC("S")="I '$P($G(^(""I"")),U,1)!$P($G(^(""I"")),U,2)"
. S DIC("A")="eRx Clinic (Optional): "
. I $G(PSOCLNC) S DIC("B")=$$GET1^DIQ(44,PSOCLNC,.01)
. D ^DIC I Y="^"!$D(DTOUT)!$D(DUOUT) S PSOQUIT=1 Q
. I $G(Y)>0 S PSOCLNC=+Y
;
I '$$CHKKEY^PSOERX(DUZ) D G EXIT
. W !,"You do not have the appropriate key to access this option." S DIR(0)="E" D ^DIR K DIR
;
D:'$D(PSOPAR) ^PSOLSET I '$D(PSOPAR) D MSG^PSODPT G EXIT
D:'$D(PSOPINST) INST^PSOORFI2 I $G(PSOIQUIT) K PSOIQUIT G EXIT
S PSNPINST=$$GET1^DIQ(59,PSOSITE,101,"I")
I 'PSNPINST W !,"NPI Institution must be defined to continue." S DIR(0)="E" D ^DIR K DIR G EXIT
;
STS ; Status Selection Prompt
K DIR S DIR(0)="SO^"
I '$D(^XUSEC("PSO ERX WORKLOAD TECH",DUZ)) S DIR(0)=DIR(0)_"A:All;N:New;I:In Progress;W:Wait;"
S DIR(0)=DIR(0)_"H:Hold;C:CCR;WP:Workload Processing"
S DIR("B")=$S($D(^XUSEC("PSO ERX WORKLOAD TECH",DUZ)):"WP",1:"A")
S DIR("?")=" "
S IDX=0
I '$D(^XUSEC("PSO ERX WORKLOAD TECH",DUZ)) D
. S IDX=IDX+1,DIR("?",IDX)=" All - View all patients with actionable prescriptions"
. S IDX=IDX+1,DIR("?",IDX)=" New - View patients with prescriptions in the 'NEW' status"
. S IDX=IDX+1,DIR("?",IDX)=" In Process - View patients with prescriptions in the 'IN PROCESS' status"
. S IDX=IDX+1,DIR("?",IDX)=" Wait - View patients with prescriptions in the 'WAIT' status"
S IDX=IDX+1,DIR("?",IDX)=" Hold - View patients with prescriptions in the 'HOLD' status"
S IDX=IDX+1,DIR("?",IDX)=" CCR - View patients with prescriptions in the 'CCR' status"
S IDX=IDX+1,DIR("?",IDX)=" Workload Processing - Process New prescriptions for one patient at a"
S IDX=IDX+1,DIR("?",IDX)=" time using FIFO (First In First Out) method"
D ^DIR I $D(DIRUT)!$D(DIROUT) G EXIT
S PSOSTFLT=Y,PSOQUIT=0
I PSOSTFLT="WP" D MATFLTR I '$G(MATFLTR) G STS
I PSOSTFLT="H" D
. K DIR S DIR(0)="SO^S:SINGLE CODE;A:ALL HOLD CODES",DIR("B")="A"
. S DIR("?")=" ",DIR("?",1)=" Single code - Allows selection of a single hold code",DIR("?",2)=" All Hold Codes - Selects all available hold codes"
. D ^DIR I $D(DIRUT)!$D(DIROUT) S PSOQUIT=1 Q
. I Y="S" S PSOHDSTS=$P($$HLDSTS^PSOERPC1(),U) I PSOHDSTS="" S PSOQUIT=1 Q
. I Y="A" S PSOHDSTS="ALL"
I PSOSTFLT="C" D
. K DIR S DIR("B")="A",DIR(0)="SO^S:SINGLE CODE;A:ALL CCR CODES"
. S DIR("?")=" ",DIR("?",1)=" Single code - Allows selection of a single CCR code",DIR("?",2)=" All CCR Codes - Selects all available CCR codes"
. D ^DIR I $D(DIRUT)!$D(DIROUT) S PSOQUIT=1 Q
. I Y="S" S PSOCCRST=$P($$CCRSTS^PSOERPC1("RXN^RXD^RXR^RXE^RXF^CAO^CAH^CAP^CAR^CAX^CAF^CXD^CXN^CXV^CXY^CXE"),U) I PSOCCRST="" S PSOQUIT=1 Q
. I Y="A" S PSOCCRST="ALL"
I PSOQUIT G STS
;
EN ; - Entry point for the PC Action in the RX View
; Loading User's preferences
D LOAD^PSOERPR0
;
I PSOSTFLT="WP" D
. D NEXTPAT
E W !,"Please wait..." D EN^VALM("PSO ERX ALL PATIENTS QUEUE")
;
G EXIT
;
LMHDR ; ListMan Header Code
D SHOW^VALM,HDR^PSOERPC0
I $G(MBMSITE) S XQORM("B")="Next Screen"
S XQORM("#")=$O(^ORD(101,"B","PSO ERX ALL PATIENTS SELECT",""))_"^1:"_VALMCNT
S XQORM("??")="D HELP^VALM2,HDR^PSOERPC0"
Q
;
HDR ; - Builds the Header section
D HDR^PSOERPC1
Q
;
INIT ; - Populates the Body section for ListMan
N LOCKPATS,PAT
K ^TMP("PSOERPC0",$J),^TMP("PSOERPCS",$J),^TMP("PSOERPAT",$J)
S PAT=0 F S PAT=$O(^XTMP("PSOERXLOCK",PAT)) Q:'PAT S LOCKPATS(PAT)=+$G(^XTMP("PSOERXLOCK",PAT))
D SETSORT^PSOERPC1,SETLINE
S:$G(VALMSG)="" VALMSG="Select the entry # to view or ?? for more actions"
Q
;
SETLINE ; - Setting Listman line
N ERXPAT,PATIEN,X1,POS,SORTORD,GROUP,CSERX
K ^TMP("PSOERPC0",$J)
I '$D(^TMP("PSOERPCS",$J)) D Q
. F I=1:1:6 S ^TMP("PSOERPC0",$J,I,0)=""
. S ^TMP("PSOERPC0",$J,7,0)=" No patients with actionable prescriptions found."
. S VALMCNT=1
;
; - Resetting list to NORMAL video attributes
D RESET^PSOERUT0()
K GRPLN,PTMTCHLN,PRMTCHLN,DRMTCHLN
;
; - Building the list (line by line)
S (GROUP,SEQ)="",LINE=0,SORTORD=$S(PSORDER="A":1,1:-1)
F S GROUP=$O(^TMP("PSOERPCS",$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("PSOERPC0",$J,LINE,0)=X,GRPLN(LINE)=LBL
. S ERXPAT="" F S ERXPAT=$O(^TMP("PSOERPCS",$J,GROUP,ERXPAT),SORTORD) Q:ERXPAT="" D
. . S PATIEN=$G(^TMP("PSOERPCS",$J,GROUP,ERXPAT,"PATIEN"))
. . S Z=$G(^TMP("PSOERPCS",$J,GROUP,ERXPAT)),SEQ=SEQ+1
. . S X1=SEQ_$S($P(Z,"^",11):"]",1:".")
. . S $E(X1,$S(SEQ>999:6,1:5))=$E($P(Z,"^",1),1,$S(SEQ>999:23,1:24)),$E(X1,30)=$P(Z,"^",2),$E(X1,41)=$$SSN^PSOERUT($P(Z,"^",3))
. . S $E(X1,54)=$J(+$P(Z,"^",4),3),$E(X1,58)=$J(+$P(Z,"^",5),2),$E(X1,61)=$J(+$P(Z,"^",6),2)
. . S $E(X1,64)=$J(+$P(Z,"^",7),2),$E(X1,67)=$J(+$P(Z,"^",8),2),$E(X1,70)=$J(+$P(Z,"^",9),3)
. . S $E(X1,74)=$J(+$P(Z,"^",10),3)
. . S $E(X1,78)=$J($P(Z,"^",5)+$P(Z,"^",6)+$P(Z,"^",7)+$P(Z,"^",8)+$P(Z,"^",9)+$P(Z,"^",10),3)
. . S LINE=LINE+1,^TMP("PSOERPC0",$J,LINE,0)=X1,^TMP("PSOERPC0",$J,SEQ,"PATIEN")=PATIEN
. . I $D(LOCKPATS(PATIEN)) S HIGHLN(LINE)=1
;
; - 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)
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
LBD ; - Change Look Back Days Parameter Action
D FULL^VALM1 S VALMBCK="R"
W ! K DIR,DIRUT,DIROUT,SAVEX
S DIR(0)="52.351,1",DIR("B")=PSOLKBKD
D ^DIR I $D(DIRUT)!$D(DIROUT) Q
S PSOLKBKD=Y,RESETLBD=0 D REF S VALMBG=1
Q
;
SQ ; - Search Queue Entry Point
D FULL^VALM1 S VALMBCK="R"
N DIR,DUOUT,DIRUT,Y,X,ERXIEN,CHANGE,ERXPTIEN,PSOFPICK
S CHANGE=0
REP ; - Repeat Prompt for additional filters
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 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:ERX REFERENCE NUMBER"
S DIR(0)=DIR(0)_";4:VISTA RX #"
S DIR(0)=DIR(0)_";5:VISTA PATIENT" I $D(VPATFLTR) S DIR(0)=DIR(0)_" "_IOINHI_"("_$$VPATFLST^PSOERUT(44)_")"_IOINORM
S DIR(0)=DIR(0)_";6:MATCH STATUS" I $G(MATFLTR) S DIR(0)=DIR(0)_" "_IOINHI_"("_$$MATCHLBL^PSOERPC2(MATFLTR)_")"_IOINORM
W !!,IOINHI,"NOTE: Only patients with actionable records are captured with this search.",IOINORM
W !,IOINHI," Non-Actionable records can be searched through the SQ action under Rx",IOINORM
W !,IOINHI," List View.",IOINORM
D ^DIR
I X'="^",X?1"^".N D G REP
. K:X="^1" PATFLTR,VPATFLTR K:X="^2" DOBFLTR K:X="^5" PATFLTR,VPATFLTR K:X="^6" MATFLTR
. S CHANGE=1
I $D(DUOUT)!($D(DIRUT)) D:CHANGE REF S:CHANGE VALMBG=1 Q
S PSOFPICK=+$G(Y)
I PSOFPICK=1 D EPATFLTR S CHANGE=1 G REP
I PSOFPICK=2 D DOBFLTR S CHANGE=1 G REP
I PSOFPICK=3 D ERXFLTR 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=4 D RXFLTR 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=5 D VPATFLTR S CHANGE=1 G REP
I PSOFPICK=6 D MATFLTR S CHANGE=1 G REP
D REF S VALMBG=1
Q
;
VPATFLTR ; - VistA Patient Filter
N DIR,PAT,XX,RANGE,COMSEG,I,J,VPAT,EPAT,DIRUT,DIROUT,QUIT
REP1 ; - Repeat VistA Patient Prompt
S DIR(0)="F^3:30",DIR("A")="VISTA PATIENT NAME"
W ! D ^DIR I $D(DIRUT)!$D(DIROUT) Q
D FIND^DIC(2,"","@;.01;.03;.114;.115;IX","",X,,"B","","","PATLST")
I '$D(PATLST("DILIST",2)) W !,"No VistA Patient found",$C(7) K PATLST G REP1
;
D PATLHDR("V")
S (QUIT,CNT)=0 K DIRUT,DTOUT
S PAT="" F S PAT=$O(PATLST("DILIST","ID",PAT)) Q:'PAT D I QUIT Q
. W !,PAT,".",?4,$E(PATLST("DILIST","ID",PAT,.01),1,30),?35,PATLST("DILIST","ID",PAT,.03)
. I PATLST("DILIST","ID",PAT,.114)'="" D
. . W ?47,$E(PATLST("DILIST","ID",PAT,.114),1,20),"-",$$STATEABB^PSOERUT(2,PATLST("DILIST",2,PAT))
. W ?71,$$FMTE^XLFDT($$LASTREDT^PSOERUT("AVPAT",PATLST("DILIST",2,PAT)),"2Z")
. S CNT=CNT+1
. I CNT>18,$O(PATLST("DILIST","ID",PAT)),$Y>(IOSL-4) D
. . K DIR S DIR(0)="E" D ^DIR I $D(DIRUT)!$D(DIROUT) S QUIT=1 Q
. . W @IOF D PATLHDR("V")
;
K DIR S DIR("A")="SELECT (1-"_+$G(PATLST("DILIST",0))_"): "
S DIR(0)="LA^1:"_+$G(PATLST("DILIST",0)) W ! D ^DIR I $D(DIRUT)!$D(DIROUT) G REP1
S RANGE=X
;
K VPATFLTR,PATFLTR
F I=1:1:$L(RANGE,",") D
. S COMSEG=$P(RANGE,",",I)
. F J=+COMSEG:1:$S(COMSEG["-":$P(COMSEG,"-",2),1:+COMSEG) D
. . S VPAT=+$G(PATLST("DILIST",2,J)) I 'VPAT Q
. . S VPATFLTR(VPAT)=""
. . S EPAT=0 F S EPAT=$O(^PS(52.49,"AVPAT",VPAT,EPAT)) Q:'EPAT D
. . . S PATFLTR(EPAT)=""
;
I '$D(PATFLTR) W !!,"There are no eRx Patients associated with the VistA Patient(s) selected.",$C(7) K VPATFLTR G REP1
Q
;
EPATFLTR ; - eRx Patient Filter
N DIR,PAT,XX,RANGE,COMSEG,I,J,RECDAT,DIRUT,DIROUT,QUIT
REP2 ; - Repeat eRx Patient Prompt
S DIR(0)="F^3:30",DIR("A")="ERX PATIENT NAME"
W ! D ^DIR I $D(DIRUT)!$D(DIROUT) Q
D FIND^DIC(52.46,"","@;.01;.08;3.3;3.4;IX","",X,,"B","","","PATLST")
I '$D(PATLST("DILIST",2)) W !,"No eRx Patient found" K PATLST G REP2
;
W ! D PATLHDR("E")
S (QUIT,CNT)=0 K DIRUT,DTOUT
S PAT="" F S PAT=$O(PATLST("DILIST","ID",PAT)) Q:'PAT D I QUIT Q
. W !,PAT,".",?4,$E(PATLST("DILIST","ID",PAT,.01),1,30)
. I PATLST("DILIST","ID",PAT,.08)'="" D
. . S X=PATLST("DILIST","ID",PAT,.08) D ^%DT W ?35,$$FMTE^XLFDT(Y,"5Z")
. I PATLST("DILIST","ID",PAT,3.3)'="" D
. . W ?47,$E(PATLST("DILIST","ID",PAT,3.3),1,20)_"-"_$$STATEABB^PSOERUT(52.46,PATLST("DILIST",2,PAT))
. S RECDAT=$O(^PS(52.49,"PAT2",PATLST("DILIST",2,PAT),999999999),-1)
. I RECDAT W ?71,$$FMTE^XLFDT(RECDAT\1,"2Z")
. S CNT=CNT+1
. I CNT>18,$O(PATLST("DILIST","ID",PAT)),$Y>(IOSL-4) D
. . K DIR S DIR(0)="E" D ^DIR I $D(DIRUT)!$D(DIROUT) S QUIT=1 Q
. . W @IOF D PATLHDR("E")
;
K DIR S DIR("A")="SELECT (1-"_+$G(PATLST("DILIST",0))_"): "
S DIR(0)="LA^1:"_+$G(PATLST("DILIST",0)) W ! D ^DIR I $D(DIRUT)!$D(DIROUT) G REP2
S RANGE=X
;
K PATFLTR
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(PATLST("DILIST",2,J)) Q
. . S PATFLTR(PATLST("DILIST",2,J))=""
Q
;
PATLHDR(PATTYP) ; - Prints the Patient List Header
;Input: Patient Type - "V": VistA Patient | "E": eRx Patient
N XX W !?73,"LAST",!,"#",?4,$S(PATTYP="E":"ERX",1:"VISTA")_" PATIENT NAME",?35,"DOB",?47,"CITY",?71,"REC.DATE"
S $P(XX,"-",80)="" W !,XX
Q
;
DOBFLTR ; - DOB Filter
N DIR,Y,X
I $G(DOBFLTR) S DIR("B")=$$FMTE^XLFDT(DOBFLTR,"2Z")
S DIR(0)="DA^:"_DT_":EX",DIR("A")="Date of Birth (DOB): "
W ! D ^DIR I $D(DIRUT)!$D(DIROUT) Q
S DOBFLTR=Y
Q
;
MATFLTR ; - Match Status Filter
N DIR,Y,X
S DIR("A")="MATCH STATUS"
S DIR(0)="SO^1:"_$S($G(MBMSITE):"PATIENT FAIL - ",1:"")_"PATIENT NOT MATCHED"
S DIR(0)=DIR(0)_";2:"_$S($G(MBMSITE):"PROVIDER FAIL - ",1:"")_"PROVIDER NOT MATCHED"
S DIR(0)=DIR(0)_";3:"_$S($G(MBMSITE):"DRUG FAIL - ",1:"")_"DRUG NOT MATCHED"
S DIR(0)=DIR(0)_";4:"_$S($G(MBMSITE):"BASIC - ",1:"")_"PATIENT, PROVIDER AND DRUG MATCHED"
I $G(PSOSTFLT)="WP" S DIR(0)=DIR(0)_";5:ALL (NO FILTERS)",DIR("B")=5
W ! D ^DIR I $D(DUOUT)!($D(DIRUT)) Q
S MATFLTR=Y
Q
;
ERXFLTR() ; - eRx ID Filter
N DIC,Y,DTOUT,DUOUT,QUIT,ERXID,ERXPTIEN
K ERXFLTR
W ! S DIC="52.49",DIC(0)="QEA",DIC("A")="ERX REFERENCE NUMBER: "
S QUIT=0
F D Q:QUIT
. D ^DIC I $D(DTOUT)!$D(DUOUT)!'Y!(X="") S QUIT=1 Q
. S ERXID=+Y
. I 'ERXID W !,"This prescription is not an eRx prescription." Q
. I '$G(MBMSITE),$$GET1^DIQ(52.49,ERXID,24.1,"I")'=PSNPINST D Q
. . W !!,"eRx belongs to a different Division: "_$$GET1^DIQ(52.49,ERXID,24.1),!,$C(7)
. S ERXPTIEN=+$$GET1^DIQ(52.49,ERXID,.04,"I")
. ; - Locking the eRx Patient
. I '$$LOCK^PSOERPC1(ERXPTIEN) D Q
. . W !!,"The patient for this eRx is currently locked by "_$$GET1^DIQ(200,+$G(^XTMP("PSOERXLOCK",ERXPTIEN)),.01)_".",!,$C(7) H 1
. S ERXFLTR=ERXID,QUIT=1
Q
;
RXFLTR() ; - Rx # Filter
N DIC,Y,DTOUT,DUOUT,QUIT,ERXID,ERXPTIEN
K ERXFLTR
W ! S DIC="52",DIC(0)="QEAM",DIC("A")="VISTA Rx #: "
S QUIT=0
F D Q:QUIT
. D ^DIC I $D(DTOUT)!$D(DUOUT)!'Y!(X="") S QUIT=1 Q
. S ERXID=$$ERXIEN^PSOERXUT(+Y)
. I 'ERXID W !,"This prescription is not an eRx prescription." Q
. I '$G(MBMSITE),$$GET1^DIQ(52.49,ERXID,24.1,"I")'=PSNPINST D Q
. . W !!,"eRx belongs to a different Division: "_$$GET1^DIQ(52.49,ERXID,24.1),!,$C(7)
. S ERXPTIEN=+$$GET1^DIQ(52.49,ERXID,.04,"I")
. ; - Locking the eRx Patient
. I '$$LOCK^PSOERPC1(ERXPTIEN) D Q
. . W !!,"The patient for this eRx is currently locked by "_$$GET1^DIQ(200,+$G(^XTMP("PSOERXLOCK",ERXPTIEN)),.01)_".",!,$C(7) H 1
. S ERXFLTR=ERXID,QUIT=1
Q
;
RF ; - Remove All Filters
K PATFLTR,VPATFLTR,DOBFLTR,MATFLTR D REF S VALMBG=1
Q
;
CS ; - Group/Un-group Controlled Substances
S PSOCSGRP=$S($G(PSOCSGRP):0,1:1) D REF
Q
;
CV ; - Change View
D EN^PSOERPR0 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
;
SEL ; - Process selection of one entry
N PSOSEL,ERXPTIEN,TMPLKBKD
S VALMBCK="R" K PSONEXTP
S PSOSEL=+$P(XQORNOD(0),"=",2) I 'PSOSEL S VALMSG="Invalid selection!",VALMBCK="R" Q
S ERXPTIEN=$G(^TMP("PSOERPC0",$J,PSOSEL,"PATIEN")) I 'ERXPTIEN S VALMSG="Invalid selection!",VALMBCK="R" Q
; - Locking the eRx Patient
I '$$LOCK^PSOERPC1(ERXPTIEN) Q
D ; - Entering the Single Patient View (Protecting Preference Parameters)
. N PSOSRTBY,PSORDER,PSOCSGRP,PSOALLST
. S TMPLKBKD=PSOLKBKD D LST^PSOERPT0(ERXPTIEN)
. I $G(RESETLBD) S PSOLKBKD=TMPLKBKD
; - Unlocking the eRx Patient
D UL^PSOERX1A(ERXPTIEN)
I $G(PSORFRSH) D REF
Q
;
NEXTPAT ; Automatically Selects the Next Patient
N ERXPTIEN,NEXTPAT
S VALMBCK="R",NEXTPAT=0
; - Locking the eRx Patient
F S ERXPTIEN=$$NEXTPAT^PSOERPC1(NEXTPAT) Q:'ERXPTIEN Q:$$LOCK^PSOERPC1(ERXPTIEN) D
. S NEXTPAT=ERXPTIEN I PSOSTFLT="WP" K ^XTMP("PSOERXWP",ERXPTIEN,DUZ)
I 'ERXPTIEN Q
D ; - Entering the Single Patient View (Protecting Preference Parameters)
. N PSOSRTBY,PSORDER,PSOCSGRP,PSOALLST
. D LST^PSOERPT0(ERXPTIEN)
; - Unlocking the eRx Patient
D UL^PSOERX1A(ERXPTIEN)
Q
;
RX ; - Switch to Rx View
D EN^PSOERRX0 S VALMBCK="Q"
Q
;
REF ; - Screen Refresh
W ?65,"Please wait..." D INIT,HDR,REVLOCKS^PSOERPC2 S VALMBCK="R"
S PSORFRSH=0
Q
;
EXIT ; - exit code
K ^TMP("PSOERPC0",$J),^TMP("PSOERPCS",$J),^TMP("PSOERPAT",$J)
D FULL^VALM1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOERPC0 16489 printed Apr 09, 2024@21:26:03 Page 2
PSOERPC0 ;BIRM/MFR - All Patients (Patient Centric) eRx Queue - ListManager ;09/28/22
+1 ;;7.0;OUTPATIENT PHARMACY;**700,750**;DEC 1997;Build 6
+2 ;
+3 ;Menu option entry point
+4 NEW MBMSITE,PSOSTFLT,PSOHDSTS,PSOCCRST,PSOSRTBY,PSORDER,PSOCSGRP,PSOLKBKD,PSOCSERX,PSOCSSCH,PSOCSGRP,PSOMAXQS
+5 NEW GRPLN,DIC,DFN,GRPLN,HIGHLN,LASTLINE,VALMCNT,PTMTCHLN,PRMTCHLN,DRMTCHLN,PATFLTR,VPATFLTR,DOBFLTR,MATFLTR,PSONEXTP
+6 NEW DIR,Y,DIRUT,DIROUT,CODE,DIRUT,DTOUT,PSOVIEW,PSOCSSCH,PSOCSERX,PSOQUIT,REDTFLTR,PRVFLTR,DRGFLTR
+7 NEW RESETLBD,PSOCLNC,PSORFRSH,IDX
+8 ;
+9 ; MBMSITE indicates whether it's an MbM site or not, RESETLBD indicates whether the Look Back Days should be reset
+10 SET MBMSITE=$SELECT($$GET1^DIQ(59.7,1,102,"I")="MBM":1,1:0)
SET RESETLBD=1
+11 ;
+12 ;Review/Clean-up Locks (e.g.,Session crased and ^XTMP global remained)
+13 DO REVLOCKS^PSOERPC2
+14 ;
+15 ;Division Selection
+16 IF '$GET(PSOSITE)
DO ^PSOLSET
IF '$DATA(PSOPAR)
WRITE $CHAR(7),!!,"Pharmacy Division Must be Selected!",!
GOTO EXIT
+17 SET PSNPINST=$$GET1^DIQ(59,PSOSITE,101,"I")
+18 ;
+19 ;Clinic Selection (MbM Sites Only)
+20 SET PSOCLNC=+$$GET1^DIQ(59,PSOSITE,10,"I")
+21 IF $GET(MBMSITE)
Begin DoDot:1
+22 WRITE !
KILL DIC
+23 SET DIC(0)="AEMQ"
SET DIC=44
SET DIC("S")="I '$P($G(^(""I"")),U,1)!$P($G(^(""I"")),U,2)"
+24 SET DIC("A")="eRx Clinic (Optional): "
+25 IF $GET(PSOCLNC)
SET DIC("B")=$$GET1^DIQ(44,PSOCLNC,.01)
+26 DO ^DIC
IF Y="^"!$DATA(DTOUT)!$DATA(DUOUT)
SET PSOQUIT=1
QUIT
+27 IF $GET(Y)>0
SET PSOCLNC=+Y
End DoDot:1
IF $GET(PSOQUIT)
GOTO EXIT
+28 ;
+29 IF '$$CHKKEY^PSOERX(DUZ)
Begin DoDot:1
+30 WRITE !,"You do not have the appropriate key to access this option."
SET DIR(0)="E"
DO ^DIR
KILL DIR
End DoDot:1
GOTO EXIT
+31 ;
+32 if '$DATA(PSOPAR)
DO ^PSOLSET
IF '$DATA(PSOPAR)
DO MSG^PSODPT
GOTO EXIT
+33 if '$DATA(PSOPINST)
DO INST^PSOORFI2
IF $GET(PSOIQUIT)
KILL PSOIQUIT
GOTO EXIT
+34 SET PSNPINST=$$GET1^DIQ(59,PSOSITE,101,"I")
+35 IF 'PSNPINST
WRITE !,"NPI Institution must be defined to continue."
SET DIR(0)="E"
DO ^DIR
KILL DIR
GOTO EXIT
+36 ;
STS ; Status Selection Prompt
+1 KILL DIR
SET DIR(0)="SO^"
+2 IF '$DATA(^XUSEC("PSO ERX WORKLOAD TECH",DUZ))
SET DIR(0)=DIR(0)_"A:All;N:New;I:In Progress;W:Wait;"
+3 SET DIR(0)=DIR(0)_"H:Hold;C:CCR;WP:Workload Processing"
+4 SET DIR("B")=$SELECT($DATA(^XUSEC("PSO ERX WORKLOAD TECH",DUZ)):"WP",1:"A")
+5 SET DIR("?")=" "
+6 SET IDX=0
+7 IF '$DATA(^XUSEC("PSO ERX WORKLOAD TECH",DUZ))
Begin DoDot:1
+8 SET IDX=IDX+1
SET DIR("?",IDX)=" All - View all patients with actionable prescriptions"
+9 SET IDX=IDX+1
SET DIR("?",IDX)=" New - View patients with prescriptions in the 'NEW' status"
+10 SET IDX=IDX+1
SET DIR("?",IDX)=" In Process - View patients with prescriptions in the 'IN PROCESS' status"
+11 SET IDX=IDX+1
SET DIR("?",IDX)=" Wait - View patients with prescriptions in the 'WAIT' status"
End DoDot:1
+12 SET IDX=IDX+1
SET DIR("?",IDX)=" Hold - View patients with prescriptions in the 'HOLD' status"
+13 SET IDX=IDX+1
SET DIR("?",IDX)=" CCR - View patients with prescriptions in the 'CCR' status"
+14 SET IDX=IDX+1
SET DIR("?",IDX)=" Workload Processing - Process New prescriptions for one patient at a"
+15 SET IDX=IDX+1
SET DIR("?",IDX)=" time using FIFO (First In First Out) method"
+16 DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)
GOTO EXIT
+17 SET PSOSTFLT=Y
SET PSOQUIT=0
+18 IF PSOSTFLT="WP"
DO MATFLTR
IF '$GET(MATFLTR)
GOTO STS
+19 IF PSOSTFLT="H"
Begin DoDot:1
+20 KILL DIR
SET DIR(0)="SO^S:SINGLE CODE;A:ALL HOLD CODES"
SET DIR("B")="A"
+21 SET DIR("?")=" "
SET DIR("?",1)=" Single code - Allows selection of a single hold code"
SET DIR("?",2)=" All Hold Codes - Selects all available hold codes"
+22 DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)
SET PSOQUIT=1
QUIT
+23 IF Y="S"
SET PSOHDSTS=$PIECE($$HLDSTS^PSOERPC1(),U)
IF PSOHDSTS=""
SET PSOQUIT=1
QUIT
+24 IF Y="A"
SET PSOHDSTS="ALL"
End DoDot:1
+25 IF PSOSTFLT="C"
Begin DoDot:1
+26 KILL DIR
SET DIR("B")="A"
SET DIR(0)="SO^S:SINGLE CODE;A:ALL CCR CODES"
+27 SET DIR("?")=" "
SET DIR("?",1)=" Single code - Allows selection of a single CCR code"
SET DIR("?",2)=" All CCR Codes - Selects all available CCR codes"
+28 DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)
SET PSOQUIT=1
QUIT
+29 IF Y="S"
SET PSOCCRST=$PIECE($$CCRSTS^PSOERPC1("RXN^RXD^RXR^RXE^RXF^CAO^CAH^CAP^CAR^CAX^CAF^CXD^CXN^CXV^CXY^CXE"),U)
IF PSOCCRST=""
SET PSOQUIT=1
QUIT
+30 IF Y="A"
SET PSOCCRST="ALL"
End DoDot:1
+31 IF PSOQUIT
GOTO STS
+32 ;
EN ; - Entry point for the PC Action in the RX View
+1 ; Loading User's preferences
+2 DO LOAD^PSOERPR0
+3 ;
+4 IF PSOSTFLT="WP"
Begin DoDot:1
+5 DO NEXTPAT
End DoDot:1
+6 IF '$TEST
WRITE !,"Please wait..."
DO EN^VALM("PSO ERX ALL PATIENTS QUEUE")
+7 ;
+8 GOTO EXIT
+9 ;
LMHDR ; ListMan Header Code
+1 DO SHOW^VALM
DO HDR^PSOERPC0
+2 IF $GET(MBMSITE)
SET XQORM("B")="Next Screen"
+3 SET XQORM("#")=$ORDER(^ORD(101,"B","PSO ERX ALL PATIENTS SELECT",""))_"^1:"_VALMCNT
+4 SET XQORM("??")="D HELP^VALM2,HDR^PSOERPC0"
+5 QUIT
+6 ;
HDR ; - Builds the Header section
+1 DO HDR^PSOERPC1
+2 QUIT
+3 ;
INIT ; - Populates the Body section for ListMan
+1 NEW LOCKPATS,PAT
+2 KILL ^TMP("PSOERPC0",$JOB),^TMP("PSOERPCS",$JOB),^TMP("PSOERPAT",$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^PSOERPC1
DO SETLINE
+5 if $GET(VALMSG)=""
SET VALMSG="Select the entry # to view or ?? for more actions"
+6 QUIT
+7 ;
SETLINE ; - Setting Listman line
+1 NEW ERXPAT,PATIEN,X1,POS,SORTORD,GROUP,CSERX
+2 KILL ^TMP("PSOERPC0",$JOB)
+3 IF '$DATA(^TMP("PSOERPCS",$JOB))
Begin DoDot:1
+4 FOR I=1:1:6
SET ^TMP("PSOERPC0",$JOB,I,0)=""
+5 SET ^TMP("PSOERPC0",$JOB,7,0)=" No patients with actionable prescriptions found."
+6 SET VALMCNT=1
End DoDot:1
QUIT
+7 ;
+8 ; - Resetting list to NORMAL video attributes
+9 DO RESET^PSOERUT0()
+10 KILL GRPLN,PTMTCHLN,PRMTCHLN,DRMTCHLN
+11 ;
+12 ; - Building the list (line by line)
+13 SET (GROUP,SEQ)=""
SET LINE=0
SET SORTORD=$SELECT(PSORDER="A":1,1:-1)
+14 FOR
SET GROUP=$ORDER(^TMP("PSOERPCS",$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("PSOERPC0",$JOB,LINE,0)=X
SET GRPLN(LINE)=LBL
End DoDot:2
+20 SET ERXPAT=""
FOR
SET ERXPAT=$ORDER(^TMP("PSOERPCS",$JOB,GROUP,ERXPAT),SORTORD)
if ERXPAT=""
QUIT
Begin DoDot:2
+21 SET PATIEN=$GET(^TMP("PSOERPCS",$JOB,GROUP,ERXPAT,"PATIEN"))
+22 SET Z=$GET(^TMP("PSOERPCS",$JOB,GROUP,ERXPAT))
SET SEQ=SEQ+1
+23 SET X1=SEQ_$SELECT($PIECE(Z,"^",11):"]",1:".")
+24 SET $EXTRACT(X1,$SELECT(SEQ>999:6,1:5))=$EXTRACT($PIECE(Z,"^",1),1,$SELECT(SEQ>999:23,1:24))
SET $EXTRACT(X1,30)=$PIECE(Z,"^",2)
SET $EXTRACT(X1,41)=$$SSN^PSOERUT($PIECE(Z,"^",3))
+25 SET $EXTRACT(X1,54)=$JUSTIFY(+$PIECE(Z,"^",4),3)
SET $EXTRACT(X1,58)=$JUSTIFY(+$PIECE(Z,"^",5),2)
SET $EXTRACT(X1,61)=$JUSTIFY(+$PIECE(Z,"^",6),2)
+26 SET $EXTRACT(X1,64)=$JUSTIFY(+$PIECE(Z,"^",7),2)
SET $EXTRACT(X1,67)=$JUSTIFY(+$PIECE(Z,"^",8),2)
SET $EXTRACT(X1,70)=$JUSTIFY(+$PIECE(Z,"^",9),3)
+27 SET $EXTRACT(X1,74)=$JUSTIFY(+$PIECE(Z,"^",10),3)
+28 SET $EXTRACT(X1,78)=$JUSTIFY($PIECE(Z,"^",5)+$PIECE(Z,"^",6)+$PIECE(Z,"^",7)+$PIECE(Z,"^",8)+$PIECE(Z,"^",9)+$PIECE(Z,"^",10),3)
+29 SET LINE=LINE+1
SET ^TMP("PSOERPC0",$JOB,LINE,0)=X1
SET ^TMP("PSOERPC0",$JOB,SEQ,"PATIEN")=PATIEN
+30 IF $DATA(LOCKPATS(PATIEN))
SET HIGHLN(LINE)=1
End DoDot:2
End DoDot:1
+31 ;
+32 ; - Saving NORMAL video attributes to be reset later
+33 IF LINE>$GET(LASTLINE)
Begin DoDot:1
+34 FOR I=($GET(LASTLINE)+1):1:LINE
DO SAVE^VALM10(I)
+35 SET LASTLINE=LINE
End DoDot:1
+36 DO VIDEO^PSOERPT1()
+37 SET VALMCNT=+$GET(LINE)
+38 QUIT
+39 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
LBD ; - Change Look Back Days Parameter Action
+1 DO FULL^VALM1
SET VALMBCK="R"
+2 WRITE !
KILL DIR,DIRUT,DIROUT,SAVEX
+3 SET DIR(0)="52.351,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 ;
SQ ; - Search Queue Entry Point
+1 DO FULL^VALM1
SET VALMBCK="R"
+2 NEW DIR,DUOUT,DIRUT,Y,X,ERXIEN,CHANGE,ERXPTIEN,PSOFPICK
+3 SET CHANGE=0
REP ; - Repeat Prompt for additional filters
+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 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:ERX REFERENCE NUMBER"
+8 SET DIR(0)=DIR(0)_";4:VISTA RX #"
+9 SET DIR(0)=DIR(0)_";5:VISTA PATIENT"
IF $DATA(VPATFLTR)
SET DIR(0)=DIR(0)_" "_IOINHI_"("_$$VPATFLST^PSOERUT(44)_")"_IOINORM
+10 SET DIR(0)=DIR(0)_";6:MATCH STATUS"
IF $GET(MATFLTR)
SET DIR(0)=DIR(0)_" "_IOINHI_"("_$$MATCHLBL^PSOERPC2(MATFLTR)_")"_IOINORM
+11 WRITE !!,IOINHI,"NOTE: Only patients with actionable records are captured with this search.",IOINORM
+12 WRITE !,IOINHI," Non-Actionable records can be searched through the SQ action under Rx",IOINORM
+13 WRITE !,IOINHI," List View.",IOINORM
+14 DO ^DIR
+15 IF X'="^"
IF X?1"^".N
Begin DoDot:1
+16 if X="^1"
KILL PATFLTR,VPATFLTR
if X="^2"
KILL DOBFLTR
if X="^5"
KILL PATFLTR,VPATFLTR
if X="^6"
KILL MATFLTR
+17 SET CHANGE=1
End DoDot:1
GOTO REP
+18 IF $DATA(DUOUT)!($DATA(DIRUT))
if CHANGE
DO REF
if CHANGE
SET VALMBG=1
QUIT
+19 SET PSOFPICK=+$GET(Y)
+20 IF PSOFPICK=1
DO EPATFLTR
SET CHANGE=1
GOTO REP
+21 IF PSOFPICK=2
DO DOBFLTR
SET CHANGE=1
GOTO REP
+22 IF PSOFPICK=3
DO ERXFLTR
if '$GET(ERXFLTR)
GOTO REP
Begin DoDot:1
+23 ; - Entering the eRx Record
+24 DO EN^PSOERX1(ERXFLTR)
+25 ; - Unlocking the eRx Patient
+26 SET ERXPTIEN=$$GET1^DIQ(52.49,ERXFLTR,.04,"I")
if 'ERXPTIEN
QUIT
+27 DO UL^PSOERX1A(ERXPTIEN)
+28 SET CHANGE=1
End DoDot:1
IF '$GET(CHANGE)
QUIT
+29 IF PSOFPICK=4
DO RXFLTR
if '$GET(ERXFLTR)
GOTO REP
Begin DoDot:1
+30 ; - Entering the eRx Record
+31 DO EN^PSOERX1(ERXFLTR)
+32 ; - Unlocking the eRx Patient
+33 SET ERXPTIEN=$$GET1^DIQ(52.49,ERXFLTR,.04,"I")
if 'ERXPTIEN
QUIT
+34 DO UL^PSOERX1A(ERXPTIEN)
+35 SET CHANGE=1
End DoDot:1
IF '$GET(CHANGE)
QUIT
+36 IF PSOFPICK=5
DO VPATFLTR
SET CHANGE=1
GOTO REP
+37 IF PSOFPICK=6
DO MATFLTR
SET CHANGE=1
GOTO REP
+38 DO REF
SET VALMBG=1
+39 QUIT
+40 ;
VPATFLTR ; - VistA Patient Filter
+1 NEW DIR,PAT,XX,RANGE,COMSEG,I,J,VPAT,EPAT,DIRUT,DIROUT,QUIT
REP1 ; - Repeat VistA Patient Prompt
+1 SET DIR(0)="F^3:30"
SET DIR("A")="VISTA PATIENT NAME"
+2 WRITE !
DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)
QUIT
+3 DO FIND^DIC(2,"","@;.01;.03;.114;.115;IX","",X,,"B","","","PATLST")
+4 IF '$DATA(PATLST("DILIST",2))
WRITE !,"No VistA Patient found",$CHAR(7)
KILL PATLST
GOTO REP1
+5 ;
+6 DO PATLHDR("V")
+7 SET (QUIT,CNT)=0
KILL DIRUT,DTOUT
+8 SET PAT=""
FOR
SET PAT=$ORDER(PATLST("DILIST","ID",PAT))
if 'PAT
QUIT
Begin DoDot:1
+9 WRITE !,PAT,".",?4,$EXTRACT(PATLST("DILIST","ID",PAT,.01),1,30),?35,PATLST("DILIST","ID",PAT,.03)
+10 IF PATLST("DILIST","ID",PAT,.114)'=""
Begin DoDot:2
+11 WRITE ?47,$EXTRACT(PATLST("DILIST","ID",PAT,.114),1,20),"-",$$STATEABB^PSOERUT(2,PATLST("DILIST",2,PAT))
End DoDot:2
+12 WRITE ?71,$$FMTE^XLFDT($$LASTREDT^PSOERUT("AVPAT",PATLST("DILIST",2,PAT)),"2Z")
+13 SET CNT=CNT+1
+14 IF CNT>18
IF $ORDER(PATLST("DILIST","ID",PAT))
IF $Y>(IOSL-4)
Begin DoDot:2
+15 KILL DIR
SET DIR(0)="E"
DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)
SET QUIT=1
QUIT
+16 WRITE @IOF
DO PATLHDR("V")
End DoDot:2
End DoDot:1
IF QUIT
QUIT
+17 ;
+18 KILL DIR
SET DIR("A")="SELECT (1-"_+$GET(PATLST("DILIST",0))_"): "
+19 SET DIR(0)="LA^1:"_+$GET(PATLST("DILIST",0))
WRITE !
DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)
GOTO REP1
+20 SET RANGE=X
+21 ;
+22 KILL VPATFLTR,PATFLTR
+23 FOR I=1:1:$LENGTH(RANGE,",")
Begin DoDot:1
+24 SET COMSEG=$PIECE(RANGE,",",I)
+25 FOR J=+COMSEG:1:$SELECT(COMSEG["-":$PIECE(COMSEG,"-",2),1:+COMSEG)
Begin DoDot:2
+26 SET VPAT=+$GET(PATLST("DILIST",2,J))
IF 'VPAT
QUIT
+27 SET VPATFLTR(VPAT)=""
+28 SET EPAT=0
FOR
SET EPAT=$ORDER(^PS(52.49,"AVPAT",VPAT,EPAT))
if 'EPAT
QUIT
Begin DoDot:3
+29 SET PATFLTR(EPAT)=""
End DoDot:3
End DoDot:2
End DoDot:1
+30 ;
+31 IF '$DATA(PATFLTR)
WRITE !!,"There are no eRx Patients associated with the VistA Patient(s) selected.",$CHAR(7)
KILL VPATFLTR
GOTO REP1
+32 QUIT
+33 ;
EPATFLTR ; - eRx Patient Filter
+1 NEW DIR,PAT,XX,RANGE,COMSEG,I,J,RECDAT,DIRUT,DIROUT,QUIT
REP2 ; - Repeat eRx Patient Prompt
+1 SET DIR(0)="F^3:30"
SET DIR("A")="ERX PATIENT NAME"
+2 WRITE !
DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)
QUIT
+3 DO FIND^DIC(52.46,"","@;.01;.08;3.3;3.4;IX","",X,,"B","","","PATLST")
+4 IF '$DATA(PATLST("DILIST",2))
WRITE !,"No eRx Patient found"
KILL PATLST
GOTO REP2
+5 ;
+6 WRITE !
DO PATLHDR("E")
+7 SET (QUIT,CNT)=0
KILL DIRUT,DTOUT
+8 SET PAT=""
FOR
SET PAT=$ORDER(PATLST("DILIST","ID",PAT))
if 'PAT
QUIT
Begin DoDot:1
+9 WRITE !,PAT,".",?4,$EXTRACT(PATLST("DILIST","ID",PAT,.01),1,30)
+10 IF PATLST("DILIST","ID",PAT,.08)'=""
Begin DoDot:2
+11 SET X=PATLST("DILIST","ID",PAT,.08)
DO ^%DT
WRITE ?35,$$FMTE^XLFDT(Y,"5Z")
End DoDot:2
+12 IF PATLST("DILIST","ID",PAT,3.3)'=""
Begin DoDot:2
+13 WRITE ?47,$EXTRACT(PATLST("DILIST","ID",PAT,3.3),1,20)_"-"_$$STATEABB^PSOERUT(52.46,PATLST("DILIST",2,PAT))
End DoDot:2
+14 SET RECDAT=$ORDER(^PS(52.49,"PAT2",PATLST("DILIST",2,PAT),999999999),-1)
+15 IF RECDAT
WRITE ?71,$$FMTE^XLFDT(RECDAT\1,"2Z")
+16 SET CNT=CNT+1
+17 IF CNT>18
IF $ORDER(PATLST("DILIST","ID",PAT))
IF $Y>(IOSL-4)
Begin DoDot:2
+18 KILL DIR
SET DIR(0)="E"
DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)
SET QUIT=1
QUIT
+19 WRITE @IOF
DO PATLHDR("E")
End DoDot:2
End DoDot:1
IF QUIT
QUIT
+20 ;
+21 KILL DIR
SET DIR("A")="SELECT (1-"_+$GET(PATLST("DILIST",0))_"): "
+22 SET DIR(0)="LA^1:"_+$GET(PATLST("DILIST",0))
WRITE !
DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)
GOTO REP2
+23 SET RANGE=X
+24 ;
+25 KILL PATFLTR
+26 FOR I=1:1:$LENGTH(RANGE,",")
Begin DoDot:1
+27 SET COMSEG=$PIECE(RANGE,",",I)
+28 FOR J=+COMSEG:1:$SELECT(COMSEG["-":$PIECE(COMSEG,"-",2),1:+COMSEG)
Begin DoDot:2
+29 IF '$DATA(PATLST("DILIST",2,J))
QUIT
+30 SET PATFLTR(PATLST("DILIST",2,J))=""
End DoDot:2
End DoDot:1
+31 QUIT
+32 ;
PATLHDR(PATTYP) ; - Prints the Patient List Header
+1 ;Input: Patient Type - "V": VistA Patient | "E": eRx Patient
+2 NEW XX
WRITE !?73,"LAST",!,"#",?4,$SELECT(PATTYP="E":"ERX",1:"VISTA")_" PATIENT NAME",?35,"DOB",?47,"CITY",?71,"REC.DATE"
+3 SET $PIECE(XX,"-",80)=""
WRITE !,XX
+4 QUIT
+5 ;
DOBFLTR ; - DOB Filter
+1 NEW DIR,Y,X
+2 IF $GET(DOBFLTR)
SET DIR("B")=$$FMTE^XLFDT(DOBFLTR,"2Z")
+3 SET DIR(0)="DA^:"_DT_":EX"
SET DIR("A")="Date of Birth (DOB): "
+4 WRITE !
DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)
QUIT
+5 SET DOBFLTR=Y
+6 QUIT
+7 ;
MATFLTR ; - Match Status Filter
+1 NEW DIR,Y,X
+2 SET DIR("A")="MATCH STATUS"
+3 SET DIR(0)="SO^1:"_$SELECT($GET(MBMSITE):"PATIENT FAIL - ",1:"")_"PATIENT NOT MATCHED"
+4 SET DIR(0)=DIR(0)_";2:"_$SELECT($GET(MBMSITE):"PROVIDER FAIL - ",1:"")_"PROVIDER NOT MATCHED"
+5 SET DIR(0)=DIR(0)_";3:"_$SELECT($GET(MBMSITE):"DRUG FAIL - ",1:"")_"DRUG NOT MATCHED"
+6 SET DIR(0)=DIR(0)_";4:"_$SELECT($GET(MBMSITE):"BASIC - ",1:"")_"PATIENT, PROVIDER AND DRUG MATCHED"
+7 IF $GET(PSOSTFLT)="WP"
SET DIR(0)=DIR(0)_";5:ALL (NO FILTERS)"
SET DIR("B")=5
+8 WRITE !
DO ^DIR
IF $DATA(DUOUT)!($DATA(DIRUT))
QUIT
+9 SET MATFLTR=Y
+10 QUIT
+11 ;
ERXFLTR() ; - eRx ID Filter
+1 NEW DIC,Y,DTOUT,DUOUT,QUIT,ERXID,ERXPTIEN
+2 KILL ERXFLTR
+3 WRITE !
SET DIC="52.49"
SET DIC(0)="QEA"
SET DIC("A")="ERX REFERENCE NUMBER: "
+4 SET QUIT=0
+5 FOR
Begin DoDot:1
+6 DO ^DIC
IF $DATA(DTOUT)!$DATA(DUOUT)!'Y!(X="")
SET QUIT=1
QUIT
+7 SET ERXID=+Y
+8 IF 'ERXID
WRITE !,"This prescription is not an eRx prescription."
QUIT
+9 IF '$GET(MBMSITE)
IF $$GET1^DIQ(52.49,ERXID,24.1,"I")'=PSNPINST
Begin DoDot:2
+10 WRITE !!,"eRx belongs to a different Division: "_$$GET1^DIQ(52.49,ERXID,24.1),!,$CHAR(7)
End DoDot:2
QUIT
+11 SET ERXPTIEN=+$$GET1^DIQ(52.49,ERXID,.04,"I")
+12 ; - Locking the eRx Patient
+13 IF '$$LOCK^PSOERPC1(ERXPTIEN)
Begin DoDot:2
+14 WRITE !!,"The patient for this eRx is currently locked by "_$$GET1^DIQ(200,+$GET(^XTMP("PSOERXLOCK",ERXPTIEN)),.01)_".",!,$CHAR(7)
HANG 1
End DoDot:2
QUIT
+15 SET ERXFLTR=ERXID
SET QUIT=1
End DoDot:1
if QUIT
QUIT
+16 QUIT
+17 ;
RXFLTR() ; - Rx # Filter
+1 NEW DIC,Y,DTOUT,DUOUT,QUIT,ERXID,ERXPTIEN
+2 KILL ERXFLTR
+3 WRITE !
SET DIC="52"
SET DIC(0)="QEAM"
SET DIC("A")="VISTA Rx #: "
+4 SET QUIT=0
+5 FOR
Begin DoDot:1
+6 DO ^DIC
IF $DATA(DTOUT)!$DATA(DUOUT)!'Y!(X="")
SET QUIT=1
QUIT
+7 SET ERXID=$$ERXIEN^PSOERXUT(+Y)
+8 IF 'ERXID
WRITE !,"This prescription is not an eRx prescription."
QUIT
+9 IF '$GET(MBMSITE)
IF $$GET1^DIQ(52.49,ERXID,24.1,"I")'=PSNPINST
Begin DoDot:2
+10 WRITE !!,"eRx belongs to a different Division: "_$$GET1^DIQ(52.49,ERXID,24.1),!,$CHAR(7)
End DoDot:2
QUIT
+11 SET ERXPTIEN=+$$GET1^DIQ(52.49,ERXID,.04,"I")
+12 ; - Locking the eRx Patient
+13 IF '$$LOCK^PSOERPC1(ERXPTIEN)
Begin DoDot:2
+14 WRITE !!,"The patient for this eRx is currently locked by "_$$GET1^DIQ(200,+$GET(^XTMP("PSOERXLOCK",ERXPTIEN)),.01)_".",!,$CHAR(7)
HANG 1
End DoDot:2
QUIT
+15 SET ERXFLTR=ERXID
SET QUIT=1
End DoDot:1
if QUIT
QUIT
+16 QUIT
+17 ;
RF ; - Remove All Filters
+1 KILL PATFLTR,VPATFLTR,DOBFLTR,MATFLTR
DO REF
SET VALMBG=1
+2 QUIT
+3 ;
CS ; - Group/Un-group Controlled Substances
+1 SET PSOCSGRP=$SELECT($GET(PSOCSGRP):0,1:1)
DO REF
+2 QUIT
+3 ;
CV ; - Change View
+1 DO EN^PSOERPR0
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 ;
SEL ; - Process selection of one entry
+1 NEW PSOSEL,ERXPTIEN,TMPLKBKD
+2 SET VALMBCK="R"
KILL PSONEXTP
+3 SET PSOSEL=+$PIECE(XQORNOD(0),"=",2)
IF 'PSOSEL
SET VALMSG="Invalid selection!"
SET VALMBCK="R"
QUIT
+4 SET ERXPTIEN=$GET(^TMP("PSOERPC0",$JOB,PSOSEL,"PATIEN"))
IF 'ERXPTIEN
SET VALMSG="Invalid selection!"
SET VALMBCK="R"
QUIT
+5 ; - Locking the eRx Patient
+6 IF '$$LOCK^PSOERPC1(ERXPTIEN)
QUIT
+7 ; - Entering the Single Patient View (Protecting Preference Parameters)
Begin DoDot:1
+8 NEW PSOSRTBY,PSORDER,PSOCSGRP,PSOALLST
+9 SET TMPLKBKD=PSOLKBKD
DO LST^PSOERPT0(ERXPTIEN)
+10 IF $GET(RESETLBD)
SET PSOLKBKD=TMPLKBKD
End DoDot:1
+11 ; - Unlocking the eRx Patient
+12 DO UL^PSOERX1A(ERXPTIEN)
+13 IF $GET(PSORFRSH)
DO REF
+14 QUIT
+15 ;
NEXTPAT ; Automatically Selects the Next Patient
+1 NEW ERXPTIEN,NEXTPAT
+2 SET VALMBCK="R"
SET NEXTPAT=0
+3 ; - Locking the eRx Patient
+4 FOR
SET ERXPTIEN=$$NEXTPAT^PSOERPC1(NEXTPAT)
if 'ERXPTIEN
QUIT
if $$LOCK^PSOERPC1(ERXPTIEN)
QUIT
Begin DoDot:1
+5 SET NEXTPAT=ERXPTIEN
IF PSOSTFLT="WP"
KILL ^XTMP("PSOERXWP",ERXPTIEN,DUZ)
End DoDot:1
+6 IF 'ERXPTIEN
QUIT
+7 ; - Entering the Single Patient View (Protecting Preference Parameters)
Begin DoDot:1
+8 NEW PSOSRTBY,PSORDER,PSOCSGRP,PSOALLST
+9 DO LST^PSOERPT0(ERXPTIEN)
End DoDot:1
+10 ; - Unlocking the eRx Patient
+11 DO UL^PSOERX1A(ERXPTIEN)
+12 QUIT
+13 ;
RX ; - Switch to Rx View
+1 DO EN^PSOERRX0
SET VALMBCK="Q"
+2 QUIT
+3 ;
REF ; - Screen Refresh
+1 WRITE ?65,"Please wait..."
DO INIT
DO HDR
DO REVLOCKS^PSOERPC2
SET VALMBCK="R"
+2 SET PSORFRSH=0
+3 QUIT
+4 ;
EXIT ; - exit code
+1 KILL ^TMP("PSOERPC0",$JOB),^TMP("PSOERPCS",$JOB),^TMP("PSOERPAT",$JOB)
+2 DO FULL^VALM1
+3 QUIT
