- 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 Jan 18, 2025@03:29:18 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