PSOERX ;ALB/BWF - eRx Utilities/RPC's ; 8/3/2016 5:14pm
;;7.0;OUTPATIENT PHARMACY;**467,527,508,551,567,591,581,617,651**;DEC 1997;Build 30
;
EN(SRCH,SORTT,PCV) ; -- main entry point for PSO ERX HOLDING QUEUE
N PSOREFSH
D EN^VALM("PSO ERX HOLDING QUEUE")
Q
;
HDR ; -- header code
N PSOLBK
S VALMHDR(1)="PSO ERX HOLDING QUEUE"
S PSOLBK=$$GET1^DIQ(59,PSOSITE,10.2,"E")
S VALMHDR(2)=$S(PSOLBK:$J(" ",21),1:$J(" ",14))_"ERX LOOK-BACK DAYS: "_$S(PSOLBK:PSOLBK,1:"Default value 365")_" ("_$$FMTE^XLFDT($$FMADD^XLFDT(DT,-$S(PSOLBK:PSOLBK,1:365)))_")"
I $G(PSOREFSH) K @VALMAR D INIT
Q
;
INIT ; -- init variables and list array
N LINE,LINEVAR,X,SGLOB,EF,ESIEN,CHKSTAT,EARY,SUBS,SUBS2,SVAL,SSTWO,EBDATE,ERXIEN,DTLOOP,PTLOOP,ERXDB,ERXDS,ERX,ERXDAT,P5246IEN,BDOVR,EEDATE
N CNT
S EF=52.49
S SGLOB=$NA(^TMP("PSOERX",$J)) K @SGLOB
S PSOSRCH=$S($D(SRCH):1,1:0) I PSOSRCH S PSOSRCH(VALMEVL)=""
S PSOSRT=$S($D(SORTT):1,1:0) I PSOSRT S PSOSRT(VALMEVL)=""
; initialize LINE
I '$G(PSOPINST) Q
F CHKSTAT="RJ","RM","PR","E" D
.S ESIEN=$$PRESOLV^PSOERXA1(CHKSTAT,"ERX") Q:'ESIEN
.S EARY(ESIEN)=""
I $D(SRCH) D
.I $D(SRCH(1)) S SUBS="EPAT",SVAL=$P(SRCH(1),U) Q
.I $D(SRCH(4)) S SUBS="EPROV",SVAL=$P(SRCH(4),U) Q
.I $D(SRCH(2)) S SUBS="F",SUBS2="DOB",SVAL=$P(SRCH(2),U) Q
.I $D(SRCH(5)) S SUBS="F",SVAL=$P(SRCH(5),U) Q
.I $D(SRCH(7)) S SUBS="MTYPE",SVAL=$P(SRCH(7),U) Q
.S SUBS="F"
I '$D(SRCH) S SUBS="F"
S (LINE,CNT)=0
; Look back 90 days
S EBDATE=$S($D(SRCH(3)):$P(SRCH(3),U),1:$$FMADD^XLFDT(DT,-90)),EEDATE=$S($D(SRCH(3)):$P(SRCH(3),U,2),1:DT_".9999")
; get lookback days override. Use it if we are not searching by date range.
S BDOVR=$$GET1^DIQ(59,PSOSITE,10.2,"E")
I $G(PCV) S BDOVR=365
I BDOVR,'$D(SRCH(3)) S EBDATE=$$FMADD^XLFDT(DT,-BDOVR)
F S EBDATE=$O(^PS(52.49,SUBS,PSNPINST,EBDATE)) Q:'EBDATE!(EBDATE>EEDATE)!(CNT>998) D
.I $G(SUBS2)="DOB" D Q
..S P5246IEN=0 F S P5246IEN=$O(^PS(52.46,SUBS2,SVAL,P5246IEN)) Q:'P5246IEN!(CNT>998) D
...S ERXIEN=0 F S ERXIEN=$O(^PS(EF,"EPAT",PSNPINST,EBDATE,P5246IEN,ERXIEN)) Q:'ERXIEN!(CNT>998) D
....D BLDITEM(ERXIEN,.CNT)
.I $G(SVAL)]"" D Q
..S ERXIEN=0 F S ERXIEN=$O(^PS(EF,SUBS,PSNPINST,EBDATE,SVAL,ERXIEN)) Q:'ERXIEN!(CNT>998) D
...I $D(PCV),$D(EARY($$GET1^DIQ(52.49,ERXIEN,1,"I"))) Q
...D BLDITEM(ERXIEN,.CNT)
.S SSTWO=0 F S SSTWO=$O(^PS(EF,SUBS,PSNPINST,EBDATE,SSTWO)) Q:'SSTWO!(CNT>998) D
..; Filter out RJ, RM, and PR status erx's if we are not searching for a specific eRx status
..I '$D(SRCH(5)),$D(EARY(SSTWO)) Q
..; if we are coming from the patient centric view, block RM, RJ, and PR.
..I $D(SRCH),$D(PCV),$D(EARY(SSTWO)) Q
..S ERXIEN=0 F S ERXIEN=$O(^PS(EF,SUBS,PSNPINST,EBDATE,SSTWO,ERXIEN)) Q:'ERXIEN!(CNT>998) D
...D BLDITEM(ERXIEN,.CNT)
S DTLOOP=0
F S DTLOOP=$O(@SGLOB@(DTLOOP)) Q:'DTLOOP D
.S PTLOOP=$S($G(SORTT)=3:0,1:"")
.S PTLOOP="" F S PTLOOP=$O(@SGLOB@(DTLOOP,PTLOOP),$S($G(SORTT)=3:-1,1:1)) Q:PTLOOP="" D
..S ERXDB="" F S ERXDB=$O(@SGLOB@(DTLOOP,PTLOOP,ERXDB)) Q:ERXDB="" D
...S ERXDS="" F S ERXDS=$O(@SGLOB@(DTLOOP,PTLOOP,ERXDB,ERXDS)) Q:ERXDS="" D
....S ERX=0 F S ERX=$O(@SGLOB@(DTLOOP,PTLOOP,ERXDB,ERXDS,ERX)) Q:'ERX D
.....S LINE=LINE+1,LINEVAR=""
.....S ERXDAT=$G(@SGLOB@(DTLOOP,PTLOOP,ERXDB,ERXDS,ERX))
.....S LINEVAR=$$SETFLD^VALM1(LINE_$S($$GET1^DIQ(52.49,ERX,95.1,"I"):"]",1:"."),LINEVAR,"#")
.....S LINEVAR=$$SETFLD^VALM1($P(ERXDAT,U),LINEVAR,"PATIENT NAME")
.....S LINEVAR=$$SETFLD^VALM1($P(ERXDAT,U,2),LINEVAR,"DOB")
.....S LINEVAR=$$SETFLD^VALM1($P(ERXDAT,U,3),LINEVAR,"DRUG")
.....S LINEVAR=$$SETFLD^VALM1($P(ERXDAT,U,4),LINEVAR,"PROVIDER")
.....S LINEVAR=$$SETFLD^VALM1($P(ERXDAT,U,8),LINEVAR,"STA")
.....S LINEVAR=$$SETFLD^VALM1($P(ERXDAT,U,7),LINEVAR,"RECORD DATE")
.....D SET^VALM10(LINE,LINEVAR,ERX)
I LINE=0 S LINE=LINE+1 D SET^VALM10(LINE,"No results for current query.")
S VALMCNT=LINE
K @SGLOB
Q
BLDITEM(ERXIEN,CNT) ;
N ERXIENS,ERXDAT,RXSTATN,MTYPE,RESTYPE,PATIEN,ERXQFLG,REQIEN,DELTA,FOUND,NMI,PATNM,NEWRX,PTDOBE,EXDS,EXPRIEN,EXPRNM
N AUTOST,MANST,ERXSTAT,ERXISTAT,ERXDT,ERXEDT,PTDOB,CSPREFIX,CSERX
; Controlled Substance Prompts Filter
I '$$CSFILTER^PSOERXUT(ERXIEN) Q
S ERXIENS=ERXIEN_","
K ERXDAT D GETS^DIQ(52.49,ERXIENS,".03;.04;.08;1;4.9;3.1;2.1;1;1.2;1.3;52.1;95.1","IE","ERXDAT")
S RXSTATN=$G(ERXDAT(EF,ERXIENS,1,"E"))
S MTYPE=$G(ERXDAT(EF,ERXIENS,.08,"I"))
S RESTYPE=$G(ERXDAT(EF,ERXIENS,52.1,"E"))
S CSERX=$G(ERXDAT(EF,ERXIENS,95.1,"I"))
I '$D(SRCH(5)),'$D(SRCH(7)),((RXSTATN="CAN")!(RXSTATN="ICA")!(RXSTATN="CNP")!(RXSTATN="CRP")!(RXSTATN="CRC")!(RXSTATN="CXP")!(RXSTATN="CXC")) Q
I '$D(SRCH(5)),'$D(SRCH(7)),((RXSTATN="CAA")!(RXSTATN="CNE")!(RXSTATN="CRN")!(RXSTATN="CRR")!(RXSTATN="CRX")!(RXSTATN="CXA")!(RXSTATN="CXQ")) Q
I '$D(SRCH(5)),'$D(SRCH(7)),(RXSTATN="CRE"),(MTYPE="CR") Q
; if the eRx is a new refill request and the status is refill request new, check for a response. if no response within 14 days, change to RRE (refill request expired)
; ChangeRequest messages will be checked for expiration status, but will not be displayed in the holding queue list view.
I MTYPE="RR",RXSTATN="RRN" D CHKEXP(ERXIEN,MTYPE)
I MTYPE="CR",RXSTATN="CRN" D CHKEXP(ERXIEN,MTYPE)
S PATIEN=$G(ERXDAT(EF,ERXIENS,.04,"I")) I 'PATIEN S PATIEN=$$GETPAT^PSOERXU5(ERXIEN)
I $D(SRCH(1)),PATIEN'=$P($G(SRCH(1)),U) Q
S PTDOB=$$GET1^DIQ(52.46,PATIEN,.08,"I")
I $D(SRCH(2)),PTDOB'=$G(SRCH(2)) Q
I '$D(SRCH)!($G(PCV)),MTYPE="IE",(RXSTATN'="RRE"),(RXSTATN'="CRE") Q
I '$D(SRCH)!($G(PCV)),MTYPE="RR" Q
; if this is not a search, is a refill response, and is a response type of 'approved', do not show in the holding queue.
I '$D(SRCH(7)),'$D(SRCH(5))!($G(PCV)),MTYPE="RE",RESTYPE="A" Q
; do not display refill response with 'approved with changes' status in the holding queue.
S ERXQFLG=0
I '$D(SRCH)!($G(PCV)),MTYPE="RE","RXP,RXC,RXA,RRP,"[RXSTATN Q
I '$D(SRCH)!($G(PCV)),MTYPE="RE",RESTYPE="AWC" D Q:ERXQFLG
.S REQIEN=$$GETREQ^PSOERXU2(ERXIEN) I 'REQIEN Q
.D RRDELTA^PSOERXU2(.DELTA,REQIEN,ERXIEN)
.I $D(DELTA(52.49,"EXTERNAL PROVIDER")) Q
.S ERXQFLG=1
I $D(SRCH(7)),MTYPE="" Q
N FOUND,NMI
S FOUND=0
I $D(SRCH(7)) D Q:'FOUND
.F NMI=1:1 D Q:$P(SRCH(7),U,NMI)=""!(FOUND)
..I $P(SRCH(7),U,NMI)=MTYPE S FOUND=1 Q
; patient name/dob
S PATNM=$$GET1^DIQ(52.46,PATIEN,.01,"E") I MTYPE="IE"!(MTYPE="OE") S PATNM=$$GET1^DIQ(52.49,ERXIEN,.08,"E")
I '$L(PATNM) D
.S NEWRX=$$RESOLV^PSOERXU2(ERXIEN)
.I NEWRX S PATNM=$$GET1^DIQ(52.49,ERXIEN,.04,"E")
.I '$L(PATNM) S PATNM=$$GET1^DIQ(52.49,ERXIEN,.08,"E")
.S PATNM="N/A"
S PTDOBE=""
I PTDOB]"" S PTDOBE=$$FMTE^XLFDT(PTDOB,"2D")
I '$L(PTDOB) S (PTDOB,PTDOBE)="N/A"
; external drug/supply
S EXDS=$G(ERXDAT(EF,ERXIENS,3.1,"E")) I '$L(EXDS) S EXDS=$$GETDRUG^PSOERXU5(ERXIEN) I '$L(EXDS) S EXDS="N/A"
I $D(SRCH(6)),EXDS'[$P($G(SRCH(6)),U) Q
; external provider ien and name
S EXPRIEN=$G(ERXDAT(EF,ERXIENS,2.1,"I")) I 'EXPRIEN S EXPRIEN=$$GETPROV^PSOERXU5(ERXIEN)
I $D(SRCH(4)),EXPRIEN'=$P($G(SRCH(4)),U,1) Q
; if there is no external provider, quit - FUTURE ENHANCEMENT - may need to find a way to log, view, and deal with these instances.
; PSO*7*508 - if there is no provider, set it to 'UNKNOWN', and do not quit (may use N/A instead)
S EXPRNM=$$GET1^DIQ(52.48,EXPRIEN,.01,"E") I '$L(EXPRNM) S EXPRNM="N/A"
; auto and manual validation status
S AUTOST=$G(ERXDAT(EF,ERXIENS,1.2,"E"))
S MANST=$G(ERXDAT(EF,ERXIENS,1.3,"E"))
S ERXSTAT=$G(ERXDAT(EF,ERXIENS,1,"E"))
S ERXISTAT=$G(ERXDAT(EF,ERXIENS,1,"I"))
I $D(SRCH(5)),ERXSTAT'=$P(SRCH(5),U,2) Q
; date ERX was received
S ERXDT=$G(ERXDAT(EF,ERXIENS,.03,"I")),ERXEDT=$$FMTE^XLFDT($P(ERXDT,"."),"2D")
S CNT=CNT+1
S CSPREFIX=$S($G(SORTBYCS,1):$S(CSERX:"A",1:"B"),1:"Z")
I $G(SORTT) D Q
.I SORTT=1 S @SGLOB@(1,CSPREFIX_PATNM,ERXDT-9999999,EXPRNM,ERXIEN)=PATNM_U_PTDOBE_U_EXDS_U_EXPRNM_U_AUTOST_U_MANST_U_ERXEDT_U_ERXSTAT
.I SORTT=2 S @SGLOB@(1,CSPREFIX_PTDOB,ERXDT-9999999,PATNM,ERXIEN)=PATNM_U_PTDOBE_U_EXDS_U_EXPRNM_U_AUTOST_U_MANST_U_ERXEDT_U_ERXSTAT
.I SORTT=3 D
..S CSPREFIX=$S($G(SORTBYCS,1):$S(CSERX:"B",1:"A"),1:"Z")
..S @SGLOB@(1,CSPREFIX_$J(ERXDT-9999999,15,6),PATNM,EXPRNM,ERXIEN)=PATNM_U_PTDOBE_U_EXDS_U_EXPRNM_U_AUTOST_U_MANST_U_ERXEDT_U_ERXSTAT
.I SORTT=4 S @SGLOB@(1,CSPREFIX_EXPRNM,ERXDT,PATNM,ERXIEN)=PATNM_U_PTDOBE_U_EXDS_U_EXPRNM_U_AUTOST_U_MANST_U_ERXEDT_U_ERXSTAT
.I SORTT=5 S @SGLOB@(1,CSPREFIX_ERXSTAT,PATNM,ERXDT-9999999,ERXIEN)=PATNM_U_PTDOBE_U_EXDS_U_EXPRNM_U_AUTOST_U_MANST_U_ERXEDT_U_ERXSTAT
.I SORTT=6 S @SGLOB@(1,CSPREFIX_EXDS,PATNM,ERXDT-9999999,ERXIEN)=PATNM_U_PTDOBE_U_EXDS_U_EXPRNM_U_AUTOST_U_MANST_U_ERXEDT_U_ERXSTAT
.I SORTT=7 D
..; MTYPE was not defined for 'newrx's from the first release. The post-init converts
..; all rx's to a newRx type
..I MTYPE="" S MTYPE="UNK"
..S @SGLOB@(1,CSPREFIX_MTYPE,ERXDT-9999999,PATNM,ERXIEN)=PATNM_U_PTDOBE_U_EXDS_U_EXPRNM_U_AUTOST_U_MANST_U_ERXEDT_U_ERXSTAT
I $D(SRCH(7)) S @SGLOB@(9999999-ERXDT,PATNM,PTDOB,EXDS,ERXIEN)=PATNM_U_PTDOBE_U_EXDS_U_EXPRNM_U_AUTOST_U_MANST_U_ERXEDT_U_ERXSTAT Q
S @SGLOB@(ERXDT,PATNM,PTDOB,EXDS,ERXIEN)=PATNM_U_PTDOBE_U_EXDS_U_EXPRNM_U_AUTOST_U_MANST_U_ERXEDT_U_ERXSTAT
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K PSOSRCH(VALMEVL),PSOSRT(VALMEVL),@VALMAR,PSOREFSH
;Kill all the new variables I created. ZRF
I VALMEVL=0 K PSOSRCH,PSOSRT
; instruct centric view to refresh
I $D(PCV) S VALMBCK="R" S PSOC1RE=1 D FULL^VALM1
K CSPREFIX,SORTBYCS
Q
;
EX ; early exit logic
K PSOSRCH,PSOSRT,SRCH,SORTT
D EX^PSOORFI1
Q
EXPND ; -- expand code
Q
;
; search list and display results
SEARCH ;
N RES,SVAL,I,DONE,SRCHARY,ERXIEN,ERXLOCK
D FULL^VALM1
S DONE=0
F I=1:1 D Q:DONE
.S RES=$$DIR(,I,.SRCHARY)
.I '+RES S DONE=1 Q
.S SRCHARY(+RES)=$P(RES,U,2,99)
.I $D(SRCHARY(8)) S DONE=1 Q
I '$D(SRCHARY) S VALMBCK="R" Q
I $G(SRCHARY(8))]"" D Q
.I '$D(^PS(52.49,"B",SRCHARY(8))) W !,"eRx could not be found." D DIRE^PSOERXX1 S VALMBCK="R" Q
.S ERXIEN=$O(^PS(52.49,"B",SRCHARY(8),0))
.I ERXIEN,$$GET1^DIQ(52.49,ERXIEN,24.1,"I")'=PSNPINST W !!,"eRx does not belong to this division.",! D DIRE^PSOERXX1 S VALMBCK="R" Q
.S PATIEN=$$GET1^DIQ(52.49,ERXIEN,.04,"I") Q:'PATIEN
.S ERXLOCK=$$L^PSOERX1A(PATIEN,1)
.I 'ERXLOCK S DIR(0)="E" D ^DIR K DIR S VALMBCK="R" Q
.D EN^PSOERX1(ERXIEN)
.D UL^PSOERX1A(PATIEN)
.S VALMBCK="R"
I $D(STYP) D EN(.SRCHARY,STYP) Q
D EN(.SRCHARY)
S VALMBCK="R"
Q
; sort target list
SORT ;
N RES,STYP,SVAL
D FULL^VALM1
S RES=$$DIR(1,0)
K DIR
I '+$P(RES,U) Q
S STYP=$P(RES,U)
S SORTBYCS=$$ASKCSSORT^PSOERXC1()
Q:SORTBYCS'?1N
I $D(SRCHARY) D EN(.SRCHARY,STYP) Q
I $D(SRCH) D EN(.SRCH,STYP,1) Q
D EN(,STYP)
Q
DIR(SORT,CNT,SLIST) ;
N DIR,Y,RLINE,STAG,SVAL
K DIR
S DIR(0)="SO^1:PATIENT NAME;2:DATE OF BIRTH;3:RECEIVED DATE RANGE;4:PROVIDER NAME;5:ERX STATUS;6:DRUG NAME;7:MESSAGE TYPE"
I '$D(SORT) S DIR(0)=DIR(0)_";8:ERX REFERENCE NUMBER"
I CNT<2 S DIR("L")="Select one of the following "_$S($G(SORT):"sort",1:"search")_" criteria:"
I CNT>1 D
.S DIR("L")=""
.S DIR("L",13)="Select another search criteria or '^' to exit. Press enter to use the currently"
.S DIR("L",14)="selected search criteria."
S DIR("L",2)=""
S DIR("L",3)=" "_$S($D(SLIST(1)):"*",1:"")_"1.) PATIENT NAME"
S DIR("L",4)=" "_$S($D(SLIST(2)):"*",1:"")_"2.) DATE OF BIRTH"
S DIR("L",5)=" "_$S($D(SLIST(3)):"*",1:"")_"3.) RECEIVED DATE"_$S('$G(SORT):" RANGE",1:"")
S DIR("L",6)=" "_$S($D(SLIST(4)):"*",1:"")_"4.) PROVIDER NAME"
S DIR("L",7)=" "_$S($D(SLIST(5)):"*",1:"")_"5.) ERX STATUS"
S DIR("L",8)=" "_$S($D(SLIST(6)):"*",1:"")_"6.) DRUG NAME"
S DIR("L",9)=" "_$S($D(SLIST(7)):"*",1:"")_"7.) MESSAGE TYPE"
I '$D(SORT) S DIR("L",10)=" "_$S($D(SLIST(8)):"*",1:"")_"8.) ERX REFERENCE NUMBER"
S DIR("L",11)=""
S DIR("L",12)=$S($D(SLIST):" * - indicates selected criteria.",1:"")
D ^DIR K DIR Q:'Y 0
S RES=Y I $G(SORT) Q RES
S RLINE=$S(RES=1:"PAT",RES=2:"DOB",RES=3:"RDT",RES=4:"PRVNM",RES=5:"ESTAT",RES=6:"DNAME",RES=7:"MTYPE",RES=8:"EREFNUM",1:"")
I RLINE']"" Q 0
S STAG=RLINE
S SVAL=$$@STAG I SVAL="" Q 0
Q RES_U_SVAL
PAT() ;
N Y,DIC
S DIC=52.46,DIC(0)="AEMQ" D ^DIC
I Y<1 Q ""
Q Y
DOB() ;
N %DT,Y
S %DT="A"
S %DT("A")="Enter the Date of Birth (DOB): "
D ^%DT
I Y<1 Q ""
Q Y
RDT() ;
N BDATE,EDATE,%DT,Y
S %DT="A"
S %DT("A")="Enter the beginning date: "
D ^%DT
I Y<0 Q ""
S BDATE=Y K Y,%DT
S %DT="A"
S %DT("A")="Enter the ending date: "
S %DT("B")="T"
D ^%DT
I Y<0 Q ""
S EDATE=Y_".999999"
Q BDATE_U_EDATE
PRVNM() ;
N Y,DIC
S DIC("A")="Select PROVIDER: "
S DIC=52.48,DIC(0)="AEQ" D ^DIC
I Y<1 Q ""
Q Y
ESTAT() ;
; prompt for erx status
N Y,DIC
S DIC("A")="Select eRx Status: "
S DIC=52.45,DIC(0)="AEQ",DIC("S")="I $D(^PS(52.45,""TYPE"",""ERX"",Y))" D ^DIC
I Y<1 Q ""
Q Y
DNAME() ;
N DIR,Y
S DIR(0)="FO"
S DIR("A")="Enter the name or partial name of the incoming eRx drug"
D ^DIR
I Y=""!(Y="^") Q ""
Q $$UP^XLFSTR(Y)
MTYPE() ;
N DIR,Y
S DIR(0)="52.49,.08",DIR("A")="Select message type" D ^DIR
I Y=""!(Y="^") Q ""
Q Y
MTYPE2 ;
N DIR,Y,DONE,SEL,SRCHARY,SORTT,SRCH,PSOSRCH,PSOSRT
S VALMBCK="R"
D FULL^VALM1
S DIR(0)="52.49,.08",DIR("A")="Select message type" D ^DIR
I Y=""!(Y="^") Q
S SRCHARY(7)=Y D EN(.SRCHARY)
Q
EREFNUM() ;
N DIR,Y
S DIR(0)="FO",DIR("A")="Enter the eRx Reference number" D ^DIR
I Y=""!(Y="^") Q ""
Q $$UP^XLFSTR(Y)
CHKKEY(DUZ) ;
I $D(^XUSEC("PSDRPH",DUZ))!($D(^XUSEC("PSO ERX ADV TECH",DUZ)))!($D(^XUSEC("PSO ERX TECH",DUZ)))!($D(^XUSEC("PSO ERX VIEW",DUZ))) Q 1
Q 0
CHKEXP(IEN,MTYPE) ;
N MSGDT,RELMSG,RELMSGT,FOUND,NMSTAT
S FOUND=0
S MSGDT=$$GET1^DIQ(52.49,IEN,.03,"I")
S RELMSG=0 F S RELMSG=$O(^PS(52.49,IEN,201,"B",RELMSG)) Q:'RELMSG D
.S RELMSGT=$$GET1^DIQ(52.49,IEN,.08,"I")
.I $G(MTYPE)="CR",RELMSGT="CX" S FOUND=1 Q
.I RELMSGT="RE" S FOUND=1
Q:FOUND
S NMSTAT=$S(MTYPE="RR":"RRX",MTYPE="CR":"CRX")
I $$FMDIFF^XLFDT(DT,MSGDT)>14 D UPDSTAT^PSOERXU1(IEN,NMSTAT)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOERX 14187 printed Sep 23, 2025@20:04:32 Page 2
PSOERX ;ALB/BWF - eRx Utilities/RPC's ; 8/3/2016 5:14pm
+1 ;;7.0;OUTPATIENT PHARMACY;**467,527,508,551,567,591,581,617,651**;DEC 1997;Build 30
+2 ;
EN(SRCH,SORTT,PCV) ; -- main entry point for PSO ERX HOLDING QUEUE
+1 NEW PSOREFSH
+2 DO EN^VALM("PSO ERX HOLDING QUEUE")
+3 QUIT
+4 ;
HDR ; -- header code
+1 NEW PSOLBK
+2 SET VALMHDR(1)="PSO ERX HOLDING QUEUE"
+3 SET PSOLBK=$$GET1^DIQ(59,PSOSITE,10.2,"E")
+4 SET VALMHDR(2)=$SELECT(PSOLBK:$JUSTIFY(" ",21),1:$JUSTIFY(" ",14))_"ERX LOOK-BACK DAYS: "_$SELECT(PSOLBK:PSOLBK,1:"Default value 365")_" ("_$$FMTE^XLFDT($$FMADD^XLFDT(DT,-$SELECT(PSOLBK:PSOLBK,1:365)))_")"
+5 IF $GET(PSOREFSH)
KILL @VALMAR
DO INIT
+6 QUIT
+7 ;
INIT ; -- init variables and list array
+1 NEW LINE,LINEVAR,X,SGLOB,EF,ESIEN,CHKSTAT,EARY,SUBS,SUBS2,SVAL,SSTWO,EBDATE,ERXIEN,DTLOOP,PTLOOP,ERXDB,ERXDS,ERX,ERXDAT,P5246IEN,BDOVR,EEDATE
+2 NEW CNT
+3 SET EF=52.49
+4 SET SGLOB=$NAME(^TMP("PSOERX",$JOB))
KILL @SGLOB
+5 SET PSOSRCH=$SELECT($DATA(SRCH):1,1:0)
IF PSOSRCH
SET PSOSRCH(VALMEVL)=""
+6 SET PSOSRT=$SELECT($DATA(SORTT):1,1:0)
IF PSOSRT
SET PSOSRT(VALMEVL)=""
+7 ; initialize LINE
+8 IF '$GET(PSOPINST)
QUIT
+9 FOR CHKSTAT="RJ","RM","PR","E"
Begin DoDot:1
+10 SET ESIEN=$$PRESOLV^PSOERXA1(CHKSTAT,"ERX")
if 'ESIEN
QUIT
+11 SET EARY(ESIEN)=""
End DoDot:1
+12 IF $DATA(SRCH)
Begin DoDot:1
+13 IF $DATA(SRCH(1))
SET SUBS="EPAT"
SET SVAL=$PIECE(SRCH(1),U)
QUIT
+14 IF $DATA(SRCH(4))
SET SUBS="EPROV"
SET SVAL=$PIECE(SRCH(4),U)
QUIT
+15 IF $DATA(SRCH(2))
SET SUBS="F"
SET SUBS2="DOB"
SET SVAL=$PIECE(SRCH(2),U)
QUIT
+16 IF $DATA(SRCH(5))
SET SUBS="F"
SET SVAL=$PIECE(SRCH(5),U)
QUIT
+17 IF $DATA(SRCH(7))
SET SUBS="MTYPE"
SET SVAL=$PIECE(SRCH(7),U)
QUIT
+18 SET SUBS="F"
End DoDot:1
+19 IF '$DATA(SRCH)
SET SUBS="F"
+20 SET (LINE,CNT)=0
+21 ; Look back 90 days
+22 SET EBDATE=$SELECT($DATA(SRCH(3)):$PIECE(SRCH(3),U),1:$$FMADD^XLFDT(DT,-90))
SET EEDATE=$SELECT($DATA(SRCH(3)):$PIECE(SRCH(3),U,2),1:DT_".9999")
+23 ; get lookback days override. Use it if we are not searching by date range.
+24 SET BDOVR=$$GET1^DIQ(59,PSOSITE,10.2,"E")
+25 IF $GET(PCV)
SET BDOVR=365
+26 IF BDOVR
IF '$DATA(SRCH(3))
SET EBDATE=$$FMADD^XLFDT(DT,-BDOVR)
+27 FOR
SET EBDATE=$ORDER(^PS(52.49,SUBS,PSNPINST,EBDATE))
if 'EBDATE!(EBDATE>EEDATE)!(CNT>998)
QUIT
Begin DoDot:1
+28 IF $GET(SUBS2)="DOB"
Begin DoDot:2
+29 SET P5246IEN=0
FOR
SET P5246IEN=$ORDER(^PS(52.46,SUBS2,SVAL,P5246IEN))
if 'P5246IEN!(CNT>998)
QUIT
Begin DoDot:3
+30 SET ERXIEN=0
FOR
SET ERXIEN=$ORDER(^PS(EF,"EPAT",PSNPINST,EBDATE,P5246IEN,ERXIEN))
if 'ERXIEN!(CNT>998)
QUIT
Begin DoDot:4
+31 DO BLDITEM(ERXIEN,.CNT)
End DoDot:4
End DoDot:3
End DoDot:2
QUIT
+32 IF $GET(SVAL)]""
Begin DoDot:2
+33 SET ERXIEN=0
FOR
SET ERXIEN=$ORDER(^PS(EF,SUBS,PSNPINST,EBDATE,SVAL,ERXIEN))
if 'ERXIEN!(CNT>998)
QUIT
Begin DoDot:3
+34 IF $DATA(PCV)
IF $DATA(EARY($$GET1^DIQ(52.49,ERXIEN,1,"I")))
QUIT
+35 DO BLDITEM(ERXIEN,.CNT)
End DoDot:3
End DoDot:2
QUIT
+36 SET SSTWO=0
FOR
SET SSTWO=$ORDER(^PS(EF,SUBS,PSNPINST,EBDATE,SSTWO))
if 'SSTWO!(CNT>998)
QUIT
Begin DoDot:2
+37 ; Filter out RJ, RM, and PR status erx's if we are not searching for a specific eRx status
+38 IF '$DATA(SRCH(5))
IF $DATA(EARY(SSTWO))
QUIT
+39 ; if we are coming from the patient centric view, block RM, RJ, and PR.
+40 IF $DATA(SRCH)
IF $DATA(PCV)
IF $DATA(EARY(SSTWO))
QUIT
+41 SET ERXIEN=0
FOR
SET ERXIEN=$ORDER(^PS(EF,SUBS,PSNPINST,EBDATE,SSTWO,ERXIEN))
if 'ERXIEN!(CNT>998)
QUIT
Begin DoDot:3
+42 DO BLDITEM(ERXIEN,.CNT)
End DoDot:3
End DoDot:2
End DoDot:1
+43 SET DTLOOP=0
+44 FOR
SET DTLOOP=$ORDER(@SGLOB@(DTLOOP))
if 'DTLOOP
QUIT
Begin DoDot:1
+45 SET PTLOOP=$SELECT($GET(SORTT)=3:0,1:"")
+46 SET PTLOOP=""
FOR
SET PTLOOP=$ORDER(@SGLOB@(DTLOOP,PTLOOP),$SELECT($GET(SORTT)=3:-1,1:1))
if PTLOOP=""
QUIT
Begin DoDot:2
+47 SET ERXDB=""
FOR
SET ERXDB=$ORDER(@SGLOB@(DTLOOP,PTLOOP,ERXDB))
if ERXDB=""
QUIT
Begin DoDot:3
+48 SET ERXDS=""
FOR
SET ERXDS=$ORDER(@SGLOB@(DTLOOP,PTLOOP,ERXDB,ERXDS))
if ERXDS=""
QUIT
Begin DoDot:4
+49 SET ERX=0
FOR
SET ERX=$ORDER(@SGLOB@(DTLOOP,PTLOOP,ERXDB,ERXDS,ERX))
if 'ERX
QUIT
Begin DoDot:5
+50 SET LINE=LINE+1
SET LINEVAR=""
+51 SET ERXDAT=$GET(@SGLOB@(DTLOOP,PTLOOP,ERXDB,ERXDS,ERX))
+52 SET LINEVAR=$$SETFLD^VALM1(LINE_$SELECT($$GET1^DIQ(52.49,ERX,95.1,"I"):"]",1:"."),LINEVAR,"#")
+53 SET LINEVAR=$$SETFLD^VALM1($PIECE(ERXDAT,U),LINEVAR,"PATIENT NAME")
+54 SET LINEVAR=$$SETFLD^VALM1($PIECE(ERXDAT,U,2),LINEVAR,"DOB")
+55 SET LINEVAR=$$SETFLD^VALM1($PIECE(ERXDAT,U,3),LINEVAR,"DRUG")
+56 SET LINEVAR=$$SETFLD^VALM1($PIECE(ERXDAT,U,4),LINEVAR,"PROVIDER")
+57 SET LINEVAR=$$SETFLD^VALM1($PIECE(ERXDAT,U,8),LINEVAR,"STA")
+58 SET LINEVAR=$$SETFLD^VALM1($PIECE(ERXDAT,U,7),LINEVAR,"RECORD DATE")
+59 DO SET^VALM10(LINE,LINEVAR,ERX)
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+60 IF LINE=0
SET LINE=LINE+1
DO SET^VALM10(LINE,"No results for current query.")
+61 SET VALMCNT=LINE
+62 KILL @SGLOB
+63 QUIT
BLDITEM(ERXIEN,CNT) ;
+1 NEW ERXIENS,ERXDAT,RXSTATN,MTYPE,RESTYPE,PATIEN,ERXQFLG,REQIEN,DELTA,FOUND,NMI,PATNM,NEWRX,PTDOBE,EXDS,EXPRIEN,EXPRNM
+2 NEW AUTOST,MANST,ERXSTAT,ERXISTAT,ERXDT,ERXEDT,PTDOB,CSPREFIX,CSERX
+3 ; Controlled Substance Prompts Filter
+4 IF '$$CSFILTER^PSOERXUT(ERXIEN)
QUIT
+5 SET ERXIENS=ERXIEN_","
+6 KILL ERXDAT
DO GETS^DIQ(52.49,ERXIENS,".03;.04;.08;1;4.9;3.1;2.1;1;1.2;1.3;52.1;95.1","IE","ERXDAT")
+7 SET RXSTATN=$GET(ERXDAT(EF,ERXIENS,1,"E"))
+8 SET MTYPE=$GET(ERXDAT(EF,ERXIENS,.08,"I"))
+9 SET RESTYPE=$GET(ERXDAT(EF,ERXIENS,52.1,"E"))
+10 SET CSERX=$GET(ERXDAT(EF,ERXIENS,95.1,"I"))
+11 IF '$DATA(SRCH(5))
IF '$DATA(SRCH(7))
IF ((RXSTATN="CAN")!(RXSTATN="ICA")!(RXSTATN="CNP")!(RXSTATN="CRP")!(RXSTATN="CRC")!(RXSTATN="CXP")!(RXSTATN="CXC"))
QUIT
+12 IF '$DATA(SRCH(5))
IF '$DATA(SRCH(7))
IF ((RXSTATN="CAA")!(RXSTATN="CNE")!(RXSTATN="CRN")!(RXSTATN="CRR")!(RXSTATN="CRX")!(RXSTATN="CXA")!(RXSTATN="CXQ"))
QUIT
+13 IF '$DATA(SRCH(5))
IF '$DATA(SRCH(7))
IF (RXSTATN="CRE")
IF (MTYPE="CR")
QUIT
+14 ; if the eRx is a new refill request and the status is refill request new, check for a response. if no response within 14 days, change to RRE (refill request expired)
+15 ; ChangeRequest messages will be checked for expiration status, but will not be displayed in the holding queue list view.
+16 IF MTYPE="RR"
IF RXSTATN="RRN"
DO CHKEXP(ERXIEN,MTYPE)
+17 IF MTYPE="CR"
IF RXSTATN="CRN"
DO CHKEXP(ERXIEN,MTYPE)
+18 SET PATIEN=$GET(ERXDAT(EF,ERXIENS,.04,"I"))
IF 'PATIEN
SET PATIEN=$$GETPAT^PSOERXU5(ERXIEN)
+19 IF $DATA(SRCH(1))
IF PATIEN'=$PIECE($GET(SRCH(1)),U)
QUIT
+20 SET PTDOB=$$GET1^DIQ(52.46,PATIEN,.08,"I")
+21 IF $DATA(SRCH(2))
IF PTDOB'=$GET(SRCH(2))
QUIT
+22 IF '$DATA(SRCH)!($GET(PCV))
IF MTYPE="IE"
IF (RXSTATN'="RRE")
IF (RXSTATN'="CRE")
QUIT
+23 IF '$DATA(SRCH)!($GET(PCV))
IF MTYPE="RR"
QUIT
+24 ; if this is not a search, is a refill response, and is a response type of 'approved', do not show in the holding queue.
+25 IF '$DATA(SRCH(7))
IF '$DATA(SRCH(5))!($GET(PCV))
IF MTYPE="RE"
IF RESTYPE="A"
QUIT
+26 ; do not display refill response with 'approved with changes' status in the holding queue.
+27 SET ERXQFLG=0
+28 IF '$DATA(SRCH)!($GET(PCV))
IF MTYPE="RE"
IF "RXP,RXC,RXA,RRP,"[RXSTATN
QUIT
+29 IF '$DATA(SRCH)!($GET(PCV))
IF MTYPE="RE"
IF RESTYPE="AWC"
Begin DoDot:1
+30 SET REQIEN=$$GETREQ^PSOERXU2(ERXIEN)
IF 'REQIEN
QUIT
+31 DO RRDELTA^PSOERXU2(.DELTA,REQIEN,ERXIEN)
+32 IF $DATA(DELTA(52.49,"EXTERNAL PROVIDER"))
QUIT
+33 SET ERXQFLG=1
End DoDot:1
if ERXQFLG
QUIT
+34 IF $DATA(SRCH(7))
IF MTYPE=""
QUIT
+35 NEW FOUND,NMI
+36 SET FOUND=0
+37 IF $DATA(SRCH(7))
Begin DoDot:1
+38 FOR NMI=1:1
Begin DoDot:2
+39 IF $PIECE(SRCH(7),U,NMI)=MTYPE
SET FOUND=1
QUIT
End DoDot:2
if $PIECE(SRCH(7),U,NMI)=""!(FOUND)
QUIT
End DoDot:1
if 'FOUND
QUIT
+40 ; patient name/dob
+41 SET PATNM=$$GET1^DIQ(52.46,PATIEN,.01,"E")
IF MTYPE="IE"!(MTYPE="OE")
SET PATNM=$$GET1^DIQ(52.49,ERXIEN,.08,"E")
+42 IF '$LENGTH(PATNM)
Begin DoDot:1
+43 SET NEWRX=$$RESOLV^PSOERXU2(ERXIEN)
+44 IF NEWRX
SET PATNM=$$GET1^DIQ(52.49,ERXIEN,.04,"E")
+45 IF '$LENGTH(PATNM)
SET PATNM=$$GET1^DIQ(52.49,ERXIEN,.08,"E")
+46 SET PATNM="N/A"
End DoDot:1
+47 SET PTDOBE=""
+48 IF PTDOB]""
SET PTDOBE=$$FMTE^XLFDT(PTDOB,"2D")
+49 IF '$LENGTH(PTDOB)
SET (PTDOB,PTDOBE)="N/A"
+50 ; external drug/supply
+51 SET EXDS=$GET(ERXDAT(EF,ERXIENS,3.1,"E"))
IF '$LENGTH(EXDS)
SET EXDS=$$GETDRUG^PSOERXU5(ERXIEN)
IF '$LENGTH(EXDS)
SET EXDS="N/A"
+52 IF $DATA(SRCH(6))
IF EXDS'[$PIECE($GET(SRCH(6)),U)
QUIT
+53 ; external provider ien and name
+54 SET EXPRIEN=$GET(ERXDAT(EF,ERXIENS,2.1,"I"))
IF 'EXPRIEN
SET EXPRIEN=$$GETPROV^PSOERXU5(ERXIEN)
+55 IF $DATA(SRCH(4))
IF EXPRIEN'=$PIECE($GET(SRCH(4)),U,1)
QUIT
+56 ; if there is no external provider, quit - FUTURE ENHANCEMENT - may need to find a way to log, view, and deal with these instances.
+57 ; PSO*7*508 - if there is no provider, set it to 'UNKNOWN', and do not quit (may use N/A instead)
+58 SET EXPRNM=$$GET1^DIQ(52.48,EXPRIEN,.01,"E")
IF '$LENGTH(EXPRNM)
SET EXPRNM="N/A"
+59 ; auto and manual validation status
+60 SET AUTOST=$GET(ERXDAT(EF,ERXIENS,1.2,"E"))
+61 SET MANST=$GET(ERXDAT(EF,ERXIENS,1.3,"E"))
+62 SET ERXSTAT=$GET(ERXDAT(EF,ERXIENS,1,"E"))
+63 SET ERXISTAT=$GET(ERXDAT(EF,ERXIENS,1,"I"))
+64 IF $DATA(SRCH(5))
IF ERXSTAT'=$PIECE(SRCH(5),U,2)
QUIT
+65 ; date ERX was received
+66 SET ERXDT=$GET(ERXDAT(EF,ERXIENS,.03,"I"))
SET ERXEDT=$$FMTE^XLFDT($PIECE(ERXDT,"."),"2D")
+67 SET CNT=CNT+1
+68 SET CSPREFIX=$SELECT($GET(SORTBYCS,1):$SELECT(CSERX:"A",1:"B"),1:"Z")
+69 IF $GET(SORTT)
Begin DoDot:1
+70 IF SORTT=1
SET @SGLOB@(1,CSPREFIX_PATNM,ERXDT-9999999,EXPRNM,ERXIEN)=PATNM_U_PTDOBE_U_EXDS_U_EXPRNM_U_AUTOST_U_MANST_U_ERXEDT_U_ERXSTAT
+71 IF SORTT=2
SET @SGLOB@(1,CSPREFIX_PTDOB,ERXDT-9999999,PATNM,ERXIEN)=PATNM_U_PTDOBE_U_EXDS_U_EXPRNM_U_AUTOST_U_MANST_U_ERXEDT_U_ERXSTAT
+72 IF SORTT=3
Begin DoDot:2
+73 SET CSPREFIX=$SELECT($GET(SORTBYCS,1):$SELECT(CSERX:"B",1:"A"),1:"Z")
+74 SET @SGLOB@(1,CSPREFIX_$JUSTIFY(ERXDT-9999999,15,6),PATNM,EXPRNM,ERXIEN)=PATNM_U_PTDOBE_U_EXDS_U_EXPRNM_U_AUTOST_U_MANST_U_ERXEDT_U_ERXSTAT
End DoDot:2
+75 IF SORTT=4
SET @SGLOB@(1,CSPREFIX_EXPRNM,ERXDT,PATNM,ERXIEN)=PATNM_U_PTDOBE_U_EXDS_U_EXPRNM_U_AUTOST_U_MANST_U_ERXEDT_U_ERXSTAT
+76 IF SORTT=5
SET @SGLOB@(1,CSPREFIX_ERXSTAT,PATNM,ERXDT-9999999,ERXIEN)=PATNM_U_PTDOBE_U_EXDS_U_EXPRNM_U_AUTOST_U_MANST_U_ERXEDT_U_ERXSTAT
+77 IF SORTT=6
SET @SGLOB@(1,CSPREFIX_EXDS,PATNM,ERXDT-9999999,ERXIEN)=PATNM_U_PTDOBE_U_EXDS_U_EXPRNM_U_AUTOST_U_MANST_U_ERXEDT_U_ERXSTAT
+78 IF SORTT=7
Begin DoDot:2
+79 ; MTYPE was not defined for 'newrx's from the first release. The post-init converts
+80 ; all rx's to a newRx type
+81 IF MTYPE=""
SET MTYPE="UNK"
+82 SET @SGLOB@(1,CSPREFIX_MTYPE,ERXDT-9999999,PATNM,ERXIEN)=PATNM_U_PTDOBE_U_EXDS_U_EXPRNM_U_AUTOST_U_MANST_U_ERXEDT_U_ERXSTAT
End DoDot:2
End DoDot:1
QUIT
+83 IF $DATA(SRCH(7))
SET @SGLOB@(9999999-ERXDT,PATNM,PTDOB,EXDS,ERXIEN)=PATNM_U_PTDOBE_U_EXDS_U_EXPRNM_U_AUTOST_U_MANST_U_ERXEDT_U_ERXSTAT
QUIT
+84 SET @SGLOB@(ERXDT,PATNM,PTDOB,EXDS,ERXIEN)=PATNM_U_PTDOBE_U_EXDS_U_EXPRNM_U_AUTOST_U_MANST_U_ERXEDT_U_ERXSTAT
+85 QUIT
+86 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL PSOSRCH(VALMEVL),PSOSRT(VALMEVL),@VALMAR,PSOREFSH
+2 ;Kill all the new variables I created. ZRF
+3 IF VALMEVL=0
KILL PSOSRCH,PSOSRT
+4 ; instruct centric view to refresh
+5 IF $DATA(PCV)
SET VALMBCK="R"
SET PSOC1RE=1
DO FULL^VALM1
+6 KILL CSPREFIX,SORTBYCS
+7 QUIT
+8 ;
EX ; early exit logic
+1 KILL PSOSRCH,PSOSRT,SRCH,SORTT
+2 DO EX^PSOORFI1
+3 QUIT
EXPND ; -- expand code
+1 QUIT
+2 ;
+3 ; search list and display results
SEARCH ;
+1 NEW RES,SVAL,I,DONE,SRCHARY,ERXIEN,ERXLOCK
+2 DO FULL^VALM1
+3 SET DONE=0
+4 FOR I=1:1
Begin DoDot:1
+5 SET RES=$$DIR(,I,.SRCHARY)
+6 IF '+RES
SET DONE=1
QUIT
+7 SET SRCHARY(+RES)=$PIECE(RES,U,2,99)
+8 IF $DATA(SRCHARY(8))
SET DONE=1
QUIT
End DoDot:1
if DONE
QUIT
+9 IF '$DATA(SRCHARY)
SET VALMBCK="R"
QUIT
+10 IF $GET(SRCHARY(8))]""
Begin DoDot:1
+11 IF '$DATA(^PS(52.49,"B",SRCHARY(8)))
WRITE !,"eRx could not be found."
DO DIRE^PSOERXX1
SET VALMBCK="R"
QUIT
+12 SET ERXIEN=$ORDER(^PS(52.49,"B",SRCHARY(8),0))
+13 IF ERXIEN
IF $$GET1^DIQ(52.49,ERXIEN,24.1,"I")'=PSNPINST
WRITE !!,"eRx does not belong to this division.",!
DO DIRE^PSOERXX1
SET VALMBCK="R"
QUIT
+14 SET PATIEN=$$GET1^DIQ(52.49,ERXIEN,.04,"I")
if 'PATIEN
QUIT
+15 SET ERXLOCK=$$L^PSOERX1A(PATIEN,1)
+16 IF 'ERXLOCK
SET DIR(0)="E"
DO ^DIR
KILL DIR
SET VALMBCK="R"
QUIT
+17 DO EN^PSOERX1(ERXIEN)
+18 DO UL^PSOERX1A(PATIEN)
+19 SET VALMBCK="R"
End DoDot:1
QUIT
+20 IF $DATA(STYP)
DO EN(.SRCHARY,STYP)
QUIT
+21 DO EN(.SRCHARY)
+22 SET VALMBCK="R"
+23 QUIT
+24 ; sort target list
SORT ;
+1 NEW RES,STYP,SVAL
+2 DO FULL^VALM1
+3 SET RES=$$DIR(1,0)
+4 KILL DIR
+5 IF '+$PIECE(RES,U)
QUIT
+6 SET STYP=$PIECE(RES,U)
+7 SET SORTBYCS=$$ASKCSSORT^PSOERXC1()
+8 if SORTBYCS'?1N
QUIT
+9 IF $DATA(SRCHARY)
DO EN(.SRCHARY,STYP)
QUIT
+10 IF $DATA(SRCH)
DO EN(.SRCH,STYP,1)
QUIT
+11 DO EN(,STYP)
+12 QUIT
DIR(SORT,CNT,SLIST) ;
+1 NEW DIR,Y,RLINE,STAG,SVAL
+2 KILL DIR
+3 SET DIR(0)="SO^1:PATIENT NAME;2:DATE OF BIRTH;3:RECEIVED DATE RANGE;4:PROVIDER NAME;5:ERX STATUS;6:DRUG NAME;7:MESSAGE TYPE"
+4 IF '$DATA(SORT)
SET DIR(0)=DIR(0)_";8:ERX REFERENCE NUMBER"
+5 IF CNT<2
SET DIR("L")="Select one of the following "_$SELECT($GET(SORT):"sort",1:"search")_" criteria:"
+6 IF CNT>1
Begin DoDot:1
+7 SET DIR("L")=""
+8 SET DIR("L",13)="Select another search criteria or '^' to exit. Press enter to use the currently"
+9 SET DIR("L",14)="selected search criteria."
End DoDot:1
+10 SET DIR("L",2)=""
+11 SET DIR("L",3)=" "_$SELECT($DATA(SLIST(1)):"*",1:"")_"1.) PATIENT NAME"
+12 SET DIR("L",4)=" "_$SELECT($DATA(SLIST(2)):"*",1:"")_"2.) DATE OF BIRTH"
+13 SET DIR("L",5)=" "_$SELECT($DATA(SLIST(3)):"*",1:"")_"3.) RECEIVED DATE"_$SELECT('$GET(SORT):" RANGE",1:"")
+14 SET DIR("L",6)=" "_$SELECT($DATA(SLIST(4)):"*",1:"")_"4.) PROVIDER NAME"
+15 SET DIR("L",7)=" "_$SELECT($DATA(SLIST(5)):"*",1:"")_"5.) ERX STATUS"
+16 SET DIR("L",8)=" "_$SELECT($DATA(SLIST(6)):"*",1:"")_"6.) DRUG NAME"
+17 SET DIR("L",9)=" "_$SELECT($DATA(SLIST(7)):"*",1:"")_"7.) MESSAGE TYPE"
+18 IF '$DATA(SORT)
SET DIR("L",10)=" "_$SELECT($DATA(SLIST(8)):"*",1:"")_"8.) ERX REFERENCE NUMBER"
+19 SET DIR("L",11)=""
+20 SET DIR("L",12)=$SELECT($DATA(SLIST):" * - indicates selected criteria.",1:"")
+21 DO ^DIR
KILL DIR
if 'Y
QUIT 0
+22 SET RES=Y
IF $GET(SORT)
QUIT RES
+23 SET RLINE=$SELECT(RES=1:"PAT",RES=2:"DOB",RES=3:"RDT",RES=4:"PRVNM",RES=5:"ESTAT",RES=6:"DNAME",RES=7:"MTYPE",RES=8:"EREFNUM",1:"")
+24 IF RLINE']""
QUIT 0
+25 SET STAG=RLINE
+26 SET SVAL=$$@STAG
IF SVAL=""
QUIT 0
+27 QUIT RES_U_SVAL
PAT() ;
+1 NEW Y,DIC
+2 SET DIC=52.46
SET DIC(0)="AEMQ"
DO ^DIC
+3 IF Y<1
QUIT ""
+4 QUIT Y
DOB() ;
+1 NEW %DT,Y
+2 SET %DT="A"
+3 SET %DT("A")="Enter the Date of Birth (DOB): "
+4 DO ^%DT
+5 IF Y<1
QUIT ""
+6 QUIT Y
RDT() ;
+1 NEW BDATE,EDATE,%DT,Y
+2 SET %DT="A"
+3 SET %DT("A")="Enter the beginning date: "
+4 DO ^%DT
+5 IF Y<0
QUIT ""
+6 SET BDATE=Y
KILL Y,%DT
+7 SET %DT="A"
+8 SET %DT("A")="Enter the ending date: "
+9 SET %DT("B")="T"
+10 DO ^%DT
+11 IF Y<0
QUIT ""
+12 SET EDATE=Y_".999999"
+13 QUIT BDATE_U_EDATE
PRVNM() ;
+1 NEW Y,DIC
+2 SET DIC("A")="Select PROVIDER: "
+3 SET DIC=52.48
SET DIC(0)="AEQ"
DO ^DIC
+4 IF Y<1
QUIT ""
+5 QUIT Y
ESTAT() ;
+1 ; prompt for erx status
+2 NEW Y,DIC
+3 SET DIC("A")="Select eRx Status: "
+4 SET DIC=52.45
SET DIC(0)="AEQ"
SET DIC("S")="I $D(^PS(52.45,""TYPE"",""ERX"",Y))"
DO ^DIC
+5 IF Y<1
QUIT ""
+6 QUIT Y
DNAME() ;
+1 NEW DIR,Y
+2 SET DIR(0)="FO"
+3 SET DIR("A")="Enter the name or partial name of the incoming eRx drug"
+4 DO ^DIR
+5 IF Y=""!(Y="^")
QUIT ""
+6 QUIT $$UP^XLFSTR(Y)
MTYPE() ;
+1 NEW DIR,Y
+2 SET DIR(0)="52.49,.08"
SET DIR("A")="Select message type"
DO ^DIR
+3 IF Y=""!(Y="^")
QUIT ""
+4 QUIT Y
MTYPE2 ;
+1 NEW DIR,Y,DONE,SEL,SRCHARY,SORTT,SRCH,PSOSRCH,PSOSRT
+2 SET VALMBCK="R"
+3 DO FULL^VALM1
+4 SET DIR(0)="52.49,.08"
SET DIR("A")="Select message type"
DO ^DIR
+5 IF Y=""!(Y="^")
QUIT
+6 SET SRCHARY(7)=Y
DO EN(.SRCHARY)
+7 QUIT
EREFNUM() ;
+1 NEW DIR,Y
+2 SET DIR(0)="FO"
SET DIR("A")="Enter the eRx Reference number"
DO ^DIR
+3 IF Y=""!(Y="^")
QUIT ""
+4 QUIT $$UP^XLFSTR(Y)
CHKKEY(DUZ) ;
+1 IF $DATA(^XUSEC("PSDRPH",DUZ))!($DATA(^XUSEC("PSO ERX ADV TECH",DUZ)))!($DATA(^XUSEC("PSO ERX TECH",DUZ)))!($DATA(^XUSEC("PSO ERX VIEW",DUZ)))
QUIT 1
+2 QUIT 0
CHKEXP(IEN,MTYPE) ;
+1 NEW MSGDT,RELMSG,RELMSGT,FOUND,NMSTAT
+2 SET FOUND=0
+3 SET MSGDT=$$GET1^DIQ(52.49,IEN,.03,"I")
+4 SET RELMSG=0
FOR
SET RELMSG=$ORDER(^PS(52.49,IEN,201,"B",RELMSG))
if 'RELMSG
QUIT
Begin DoDot:1
+5 SET RELMSGT=$$GET1^DIQ(52.49,IEN,.08,"I")
+6 IF $GET(MTYPE)="CR"
IF RELMSGT="CX"
SET FOUND=1
QUIT
+7 IF RELMSGT="RE"
SET FOUND=1
End DoDot:1
+8 if FOUND
QUIT
+9 SET NMSTAT=$SELECT(MTYPE="RR":"RRX",MTYPE="CR":"CRX")
+10 IF $$FMDIFF^XLFDT(DT,MSGDT)>14
DO UPDSTAT^PSOERXU1(IEN,NMSTAT)
+11 QUIT
