PSOERBT ;ALB/RM - Handles Multiple eRx CH REQ Submission & Drug Conversion (MbM) ;Jan 16, 2025@12:43:34
;;7.0;OUTPATIENT PHARMACY;**770**;DEC 16, 1997;Build 145
;
EN ; main entry point of the menu option
N DIR,X,Y,CONVTYPE,BEGFLDT,ENDFLDT,ALLOWSUB,MBMSITE,PSOQUIT,ERXNERX,CHRQTYPE,NOTE2PRV,FROMDRUG,NEWDRUG,VRXSIG,PSOALLST
S MBMSITE=$S($$GET1^DIQ(59.7,1,102,"I")="MBM":1,1:0)
;
;Division Selection
I '$G(PSOSITE) D ^PSOLSET I '$D(PSOPAR) W $C(7),!!,"Pharmacy Division Must be Selected!",! G EXIT
S PSNPINST=$$GET1^DIQ(59,PSOSITE,101,"I")
;
K DIR S DIR("A")="CHOOSE BATCH CONVERSION TYPE"
S DIR(0)="S^CR:MULTIPLE ERX CHANGE REQUEST SUBMISSION;DR:VISTA DISPENSE DRUG REPLACEMENT (MbM ONLY)"
S DIR("?",1)="CR - Use this option to send the same eRx Change Request to the external"
S DIR("?",2)=" prescribers for multiple VistA Rx's issued within a date range."
S DIR("?",3)=" "
S DIR("?",4)="DR - *** Available to Meds-by-Mail only ***"
S DIR("?",5)=" Use this option to replace the VistA dispense drug for multiple VistA"
S DIR("?",6)=" Rx's issued within a date range."
S DIR("?")=" "
D ^DIR I $D(DIRUT)!$D(DIROUT) G EXIT
I Y="DR",'MBMSITE W !!,"This option is available for MbM sites only",$C(7) D PAUSE^PSOSPMU1 G EXIT
S CONVTYPE=Y
;
I CONVTYPE="DR",'$D(^XUSEC("PSNMGR",DUZ)) D G EXIT
. W !,"You need to hold the PSNMGR key to access this option." S DIR(0)="E" D ^DIR K DIR
;
; Ask for TYPE OF CHANGE REQUEST for Change Request submission
S PSOQUIT=0
I CONVTYPE="CR" D I PSOQUIT G EXIT
. N X,Y,DIC,DONE,FROMOI,TOOI,FROMSTRN,TOSTREN,ERXIEN
. S (CHRQTYPE,NOTE2PRV,FROMDRUG,NEWDRUG,RXHASH)=""
. K DIR S DIR("A")="TYPE OF CHANGE REQUEST"
. S DIR(0)="S^1:CHANGE REQUEST FOR SAME DRUG/SIG RX'S;2:DRUG REPLACEMENT FOR SIMILAR VISTA DRUG;3:CHANGE REQUEST W/OUT DRUG SUGGESTION(S)"
. S DIR("?",1)="1 - The software will search for VistA Rx's with the same dispense drug"
. S DIR("?",2)=" and SIG, then it will allow you to send the same eRx Change Request"
. S DIR("?",3)=" for these Rx's. "
. S DIR("?",4)=" "
. S DIR("?",5)="2 - The software will search for VistA Rx's with the same dispense drug"
. S DIR("?",6)=" and will allow you to indicate a new dispense drug that will be used"
. S DIR("?",7)=" as a suggestion for an eRx Change Request that can be sent for these"
. S DIR("?",8)=" Rx's."
. S DIR("?",9)=" "
. S DIR("?",10)="3 - The software will search for VistA Rx's with the same dispense drug,"
. S DIR("?",11)=" then it will allow you to send the same eRx Change Request without a"
. S DIR("?",12)=" a drug suggestion for these Rx's."
. S DIR("?")=" "
. D ^DIR I $D(DIRUT)!$D(DIROUT) S PSOQUIT=1 Q
. S CHRQTYPE=+Y
;
; Change Request for Same Drug/SIG Rx's (option 1) - Addt'l prompt
I CONVTYPE="CR",+$G(CHRQTYPE)=1 D I PSOQUIT G EXIT
. W ! K DIC S DIC="52",DIC(0)="AEMQZV",DIC("A")="VISTA RX #: "
. S (DONE,PSOQUIT)=0
. F D Q:(DONE!PSOQUIT)
. . ;keep prompting until user enter a valid entry
. . D ^DIC I $D(DTOUT)!$D(DUOUT) S PSOQUIT=1 Q
. . I (+Y<1)!(X="") W !!,"Required!",!,$C(7) Q
. . S VRXIEN=+Y,ERXIEN=$$ERXIEN^PSOERXUT(VRXIEN)
. . I ERXIEN="" W !," Not an eRx Prescription.",! Q
. . S FROMDRUG=$$GET1^DIQ(52,VRXIEN,6,"I"),VRXSIG=$$RXSIG^PSOERBT1(VRXIEN)
. . I 'FROMDRUG W !,"There's a problem with the Drug in this Rx.",! Q
. . I VRXSIG="" W !,"There's a problem with the SIG in this Rx.",! Q
. . S DONE=1
. I PSOQUIT Q
;
; Drug Replacement for Similar VistA Drug (option 2) - Addt'l prompts
I CONVTYPE="DR"!((CONVTYPE="CR")&($G(CHRQTYPE)=2)) D I PSOQUIT G EXIT
. W ! K DIC,X,Y S DIC="50",DIC(0)="AEMQZI",DIC("A")="FROM VISTA DRUG: ",D="B^AQ1"
. S DIC("S")="I ($$OUTPAT^PSOERXA0(+Y))"
. S (DONE,PSOQUIT)=0
. F D Q:(DONE!PSOQUIT)
. . ;keep prompting until user enter a valid entry
. . D MIX^DIC1 I $D(DTOUT)!$D(DUOUT) S PSOQUIT=1 Q
. . I (+Y<1)!(X="") W !!,"Required!",!,$C(7) Q
. . I CONVTYPE="CR",$$GETNDC^PSSNDCUT(+Y,$G(PSOSITE))="" W !!,"Drug does not have an NDC code!",!,$C(7) Q
. . S FROMDRUG=+Y,DONE=1
. I PSOQUIT Q
. ;
. W ! K DIC,X,Y S DIC="50",DIC(0)="AEMQZI",DIC("A")="NEW VISTA DRUG: "
. S DIC("S")="I $$ACTIVE^PSOERXA0(+Y),($$OUTPAT^PSOERXA0(+Y)),+Y'=FROMDRUG",D="B^AQ1"
. S (DONE,PSOQUIT)=0
. F D Q:(DONE!PSOQUIT)
. . ;keep prompting until user enter a valid entry
. . D MIX^DIC1 I $D(DTOUT)!$D(DUOUT) S PSOQUIT=1 Q
. . I (+Y<1)!(X="") W !!,"Required!",!,$C(7) Q
. . I $$GETNDC^PSSNDCUT(+Y,$G(PSOSITE))="" W !!,"Drug does not have an NDC code!",!,$C(7) Q
. . I +Y=FROMDRUG W !!,"Cannot be the same drug!",!,$C(7) Q
. . S NEWDRUG=+Y,DONE=1
. I PSOQUIT Q
. ;
. ; Warnings about the 2 dispense drugs selected
. I $$GET1^DIQ(50,FROMDRUG,2)'=$$GET1^DIQ(50,NEWDRUG,2) D
. . W !!,"WARNING: Drugs selected belong to different VA Classes:",$C(7)
. . W !," - ",$$GET1^DIQ(50,FROMDRUG,2)
. . W !," - ",$$GET1^DIQ(50,NEWDRUG,2)
. . D PAUSE^PSOERXUT
. ; Warnings about the 2 dispense drugs selected
. S FROMOI=$$GET1^DIQ(50,FROMDRUG,2.1,"I"),TOOI=$$GET1^DIQ(50,NEWDRUG,2.1,"I")
. I FROMOI'=TOOI D
. . W !!,"WARNING: Drugs selected belong to different Orderable Items:",$C(7)
. . W !," - ",$$GET1^DIQ(50,FROMDRUG,2.1)
. . W !," - ",$$GET1^DIQ(50,NEWDRUG,2.1)
. . D PAUSE^PSOERXUT
. S FROMSTRN=$$GET1^DIQ(50,FROMDRUG,901)_$$GET1^DIQ(50,FROMDRUG,902)_" "_$$GET1^DIQ(50.7,FROMOI,.02)
. S TOSTREN=$$GET1^DIQ(50,NEWDRUG,901)_$$GET1^DIQ(50,NEWDRUG,902)_" "_$$GET1^DIQ(50.7,TOOI,.02)
. I FROMSTRN'=TOSTREN D
. . W !!,"WARNING: Drugs selected have different strengths/form:",$C(7)
. . W !," - ",FROMSTRN
. . W !," - ",TOSTREN
. . D PAUSE^PSOSPMU1
;
; Change Request w/out Drug Suggestion(s) (option 3) - Addt'l prompt
I CONVTYPE="CR",+$G(CHRQTYPE)=3 D I PSOQUIT G EXIT
. W ! K DIC S DIC="50",DIC(0)="AEMQZI",DIC("A")="VISTA DRUG: "
. S DIC("S")="I $$OUTPAT^PSOERXA0(+Y)",D="B^AQ1"
. S (DONE,PSOQUIT)=0
. F D Q:DONE
. . ;keep prompting until user enter a valid entry
. . D MIX^DIC1 I $D(DTOUT)!$D(DUOUT) S (DONE,PSOQUIT)=1 Q
. . I (+Y<1)!(X="") W !!,"Required!",!,$C(7) Q
. . I $$GETNDC^PSSNDCUT(+Y,$G(PSOSITE))="" W !!,"Drug does not have an NDC code!",!,$C(7) Q
. . S FROMDRUG=+Y,DONE=1
;
; - Ask for FROM FILL DATE
S %DT(0)=$$FMADD^XLFDT(DT,-366),%DT="AEP",%DT("A")="BEGIN ISSUE DATE: ",%DT("B")=$$FMTE^XLFDT($$FMADD^XLFDT(DT,-366),"2Y")
W ! D ^%DT I Y<0!($D(DTOUT)) G EXIT
S BEGFLDT=Y\1-.00001
;
; - Ask for END FILL DATE
S %DT(0)=BEGFLDT+1\1,%DT("A")="END ISSUE DATE: ",%DT("B")=$$FMTE^XLFDT(DT,"2Y")
W ! D ^%DT I Y<0!($D(DTOUT)) G EXIT
S ENDFLDT=Y\1+.99999
;
; Ask for the type of prescription (eRx or Non-eRx)
S ERXNERX="",PSOQUIT=0
I CONVTYPE="DR" D I PSOQUIT G EXIT
. K DIR S DIR("A")="PRESCRIPTION TYPE (ERX/NON-ERX/BOTH)",DIR("B")="B"
. S DIR(0)="SO^E:ERX PRESCRIPTIONS ONLY;N:NON-ERX PRESCRIPTIONS ONLY;B:BOTH"
. S DIR("?")=" ",DIR("?",1)=" E - eRx Prescriptions only"
. S DIR("?",2)=" N - Non-eRx (Backdoor and CPRS) Prescriptions only"
. S DIR("?",2)=" B - Both, eRx and non-eRx prescriptions"
. D ^DIR I $D(DIRUT)!$D(DIROUT) S PSOQUIT=1
. S ERXNERX=Y
;
; Ask if the Rx should be included based on the Substitution being allowed or not
S ALLOWSUB="",PSOQUIT=0
I CONVTYPE="CR"!(ERXNERX="E")!(ERXNERX="B") D I PSOQUIT G EXIT
. K DIR S DIR("A")="SUBSTITUTION (eRx ONLY)",DIR("B")="B"
. S DIR(0)="SO^A:SUBSTITUTION ALLOWED;N:SUBSTITUTION NOT ALLOWED;B:BOTH"
. S DIR("?",1)="Only applies to eRx prescriptions"
. S DIR("?",2)=""
. S DIR("?",3)=" A - eRx's w/ Substitution allowed only (NO PRODUCT SELECTION INDICATED)"
. S DIR("?",4)=" N - eRx's w/ Substitution NOT allowed only (SUBS. NOT ALLOWED BY PRESCRIBER)"
. S DIR("?")=" B - Both, include all"
. D ^DIR I $D(DIRUT)!$D(DIROUT) S PSOQUIT=1
. S ALLOWSUB=Y
;
D EN^VALM("PSO ERX BATCH ERX CHANGE")
;
G EXIT
Q
;
LMHDR ; Menu Protocol Header Code
D SHOW^VALM,HDR
S XQORM("#")=$O(^ORD(101,"B","PSO ERX BATCH CHANGE REQUEST SELECT",""))_"^1:"_VALMCNT
S XQORM("??")="D HELP^VALM2,HDR^PSOERBT"
Q
;
HDR ; Listman Header Code
N HDR,I,DRUG,SIG,DOSE,HIGH,NORM,ERXIEN
;
S VALM("TITLE")=$S(CONVTYPE="CR":"Batch eRx CH REQ Submission",1:"Dispense Drug Replacement")
S HIGH=$G(IOINHI),NORM=$G(IOINORM)
S HDR="DATE RANGE: "_HIGH_$$FMTE^XLFDT($G(BEGFLDT)+.01\1,"2Z")_NORM
S HDR=HDR_" - "_HIGH_$$FMTE^XLFDT($G(ENDFLDT)\1,"2Z")_NORM
S HDR=HDR_" SUBS: "_HIGH_$S(ALLOWSUB="A":"ALLOWED ONLY",ALLOWSUB="N":"NOT ALLOWED ONLY",ALLOWSUB="B":"ALLOWED & NOT ALLOWED",1:"N/A")_NORM
S HDR=HDR_$J("RX COUNT: "_HIGH_$S('$O(^TMP("PSOERBT",$J,0)):0,1:VALMCNT)_NORM,$S(ALLOWSUB="A":34,ALLOWSUB="N":30,ALLOWSUB="B":25,1:43))
D INSTR^VALM1(HDR,1,2)
;
I CONVTYPE="CR" D ; eRx CH REQUEST header
. I CHRQTYPE=1 D
. . S DRUG=$$GET1^DIQ(52,FROMDRUG,6,"I")
. . S HDR="VISTA DRUG: "_HIGH_$E($$GET1^DIQ(50,FROMDRUG,.01),1,40)_" (CMOP ID: "_$$GET1^DIQ(50,FROMDRUG,27)_")"_NORM D INSTR^VALM1(HDR,1,3)
. . S SIG=VRXSIG S HDR="SIG: "_HIGH_$E(SIG,1,75)_NORM D INSTR^VALM1(HDR,1,4)
. . S HDR=$E(SIG,76,999)
. . I HDR'="" S HDR=HIGH_$S($L(HDR)<55:HDR,1:$E(HDR,1,51)_"...")_NORM D INSTR^VALM1(HDR,1,5)
. I CHRQTYPE=2 D
. . S HDR="FROM VISTA DRUG: "_HIGH_$E($$GET1^DIQ(50,FROMDRUG,.01),1,40)_" (CMOP ID: "_$$GET1^DIQ(50,FROMDRUG,27)_")"_NORM D INSTR^VALM1(HDR,1,3)
. . S HDR=" NEW VISTA DRUG: "_HIGH_$E($$GET1^DIQ(50,NEWDRUG,.01),1,40)_" (CMOP ID: "_$$GET1^DIQ(50,NEWDRUG,27)_")"_NORM D INSTR^VALM1(HDR,1,4)
. I CHRQTYPE=3 D
. . S HDR="VISTA DRUG: "_HIGH_$E($$GET1^DIQ(50,FROMDRUG,.01),1,40)_" (CMOP ID: "_$$GET1^DIQ(50,FROMDRUG,27)_")"_NORM D INSTR^VALM1(HDR,1,3)
E D ; VistA Drug Replacement header
. S HDR="FROM VISTA DRUG: "_HIGH_$$GET1^DIQ(50,FROMDRUG,.01)_" (CMOP ID: "_$$GET1^DIQ(50,FROMDRUG,27)_")"_NORM D INSTR^VALM1(HDR,1,3)
. S HDR=" NEW VISTA DRUG: "_HIGH_$$GET1^DIQ(50,NEWDRUG,.01)_" (CMOP ID: "_$$GET1^DIQ(50,NEWDRUG,27)_")"_NORM D INSTR^VALM1(HDR,1,4)
. S HDR="ERX/NON-ERX : "_HIGH_$S(ERXNERX="E":"ERX ONLY",ERXNERX="N":"NON-ERX ONLY",1:"BOTH")_NORM D INSTR^VALM1(HDR,1,5)
;
S HDR="DAY",$E(HDR,5)="REF",$E(HDR,9)="LAST",$E(HDR,18)="LAST CH "
D INSTR^VALM1($G(IORVON)_HDR_NORM,56,5)
S HDR="#",$E(HDR,6)="VISTA RX #",$E(HDR,21)="PATIENT",$E(HDR,48)="STA",$E(HDR,52)="QTY",$E(HDR,56)="SUP",$E(HDR,60)="REM"
S $E(HDR,64)="FILL",$E(HDR,73)="REQUEST",$E(HDR,81)=""
D INSTR^VALM1($G(IORVON)_HDR_NORM,1,6)
S XQORM("??")="D HELP^VALM2,HDR^PSOERBT"
Q
;
INIT ; -- init variables and list array
N I,HIGHLN,HIGUNDLN,REVLN,BLINKLN,PSOERBT,BFLDT,RXIEN,ISSUEDT,RXIEN
S VALMBG=1,LINE=0 K ^TMP("PSOERBTS",$J),^TMP("PSOERBT",$J)
D RESET^PSOERUT0() ; - Resetting list to NORMAL video attributes
;
W !!,"Please wait..."
S BFLDT=BEGFLDT,LINE=0
F S BFLDT=$O(^PSRX("ADL",BFLDT)) Q:BFLDT="" D
. S RXIEN="" F S RXIEN=$O(^PSRX("ADL",BFLDT,FROMDRUG,RXIEN)) Q:RXIEN="" D
. . S ISSUEDT=$$GET1^DIQ(52,RXIEN,1,"I") I $D(^TMP("PSOERBTS",$J,ISSUEDT,RXIEN)) Q
. . I ISSUEDT>ENDFLDT Q ;issue date vs end date check
. . I FROMDRUG'=$$GET1^DIQ(52,RXIEN,6,"I") Q
. . S ERXIEN=$$ERXIEN^PSOERXUT(RXIEN)
. . I ERXIEN,ALLOWSUB'="B",$$GET1^DIQ(52.49,ERXIEN,5.8,"I")'=$S(ALLOWSUB="A":0,1:1) Q ;substitution check
. . I CONVTYPE="CR",'ERXIEN Q ;Not an eRx prescription
. . I '$G(PSOALLST),",0,3,5,"'[(","_$$GET1^DIQ(52,RXIEN,100,"I")_",") Q ;rx status check (ACTIVE,HOLD,SUSPENDED)
. . I CONVTYPE="CR",CHRQTYPE=1,VRXSIG'=$$RXSIG^PSOERBT1(RXIEN) Q
. . I CONVTYPE="DR",ERXNERX="N",ERXIEN Q
. . I CONVTYPE="DR",ERXNERX="E",'ERXIEN Q
. . S ^TMP("PSOERBTS",$J,ISSUEDT,RXIEN)=ERXIEN
;
S (ISSUEDT,RXIEN)=""
F S ISSUEDT=$O(^TMP("PSOERBTS",$J,ISSUEDT)) Q:'ISSUEDT D
. F S RXIEN=$O(^TMP("PSOERBTS",$J,ISSUEDT,RXIEN)) Q:'RXIEN D
. . D ADRX2LST(RXIEN,+$G(^TMP("PSOERBTS",$J,ISSUEDT,RXIEN)))
K ^TMP("PSOERBTS",$J)
;
I '$O(^TMP("PSOERBT",$J,0)) D Q
. F I=1:1:6 S ^TMP("PSOERBT",$J,I,0)=""
. S ^TMP("PSOERBT",$J,7,0)=" There were no records found that met the above criteria.",HIGHLN(7,4)=80
. D VIDEO^PSOERUT0() ; Changes the Video Attributes for the list
. S VALMCNT=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^PSOERUT0() ; Changes the Video Attributes for the list
S VALMCNT=$O(^TMP("PSOERBT",$J,""),-1)
Q
;
ADRX2LST(RXIEN,ERXIEN) ;Add the prescription to the list for display
;Input: ERXIEN - Pointer to the PRESCRIPTION file (#52)
; (o)RXIEN - Pointer to the ERX HOLDING QUEUE file (#52.49)
N STA,STAT,PSOCMOP,LASTCHREQ,VISTARX,LASTFLDT,PTNAME,NUMREFS,PROVIDER,QUANTITY,DAYSUP
S STA="A^N^R^H^N^S^^^^^^E^DC^^DP^DE^HP^P^"
S PSOCMOP=""
S LASTCHREQ=$$LSTCHREQ^PSOERBT2(ERXIEN)
S VISTARX=$$GET1^DIQ(52,RXIEN,.01,"E")
S PSOCMOP=$$ISCMOPD^PSOERBT2(RXIEN) ;determine if rx is cmop dispense/transmitted, etc.
S STAT=$P(STA,"^",$$GET1^DIQ(52,RXIEN,100,"I")+1) D
. I $G(^PSRX(RXIEN,"DDSTA"))]"" S STAT="DD" Q
. I $G(^PSRX(RXIEN,"PARK")),STA="A" S STAT="AP"
S STAT=$S($P($G(^PSRX(RXIEN,7)),"^")=1:"DA",$P($G(^PSRX(RXIEN,7)),"^")=2:"DF",1:STAT)
S STAT=STAT_PSOCMOP,DAYSUP=$$GET1^DIQ(52,RXIEN,8)
S LASTFLDT=$$RXFLDT^PSOBPSUT(RXIEN),PTNAME=$$GET1^DIQ(52,RXIEN,2,"E"),PROVIDER=$$GET1^DIQ(52,RXIEN,4,"E")
S QUANTITY=+$$GET1^DIQ(52,RXIEN,7,"I"),NUMREFS=+$$GET1^DIQ(52,RXIEN,9,"I")-$$LSTRFL^PSOBPSU1(RXIEN)
S LINE=LINE+1,LINETXT=LINE_"."
S $E(LINETXT,6)=$S(ERXIEN:"& ",1:"")_VISTARX,$E(LINETXT,21)=$E(PTNAME,1,26),$E(LINETXT,48)=STAT,$E(LINETXT,52)=$J(QUANTITY,3)
S $E(LINETXT,56)=$J(DAYSUP,3),$E(LINETXT,60)=$J(NUMREFS,3),$E(LINETXT,64)=$TR($$FMTE^XLFDT(LASTFLDT,"2Z"),"/","-")
S $E(LINETXT,73)=$TR($$FMTE^XLFDT($$LSTCHREQ^PSOERBT2(ERXIEN),"2Z"),"/","-")
S ^TMP("PSOERBT",$J,LINE,0)=LINETXT
S ^TMP("PSOERBT",$J,LINE,"RXIEN")=RXIEN
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
S VALMBCK="R"
Q
;
EXIT ; -- exit code
K ^TMP("PSOERBT",$J),^TMP("PSOERSEL",$J)
D CLEAR^VALM1
D FULL^VALM1
Q
;
SEL ;Process selection of one entry
N PSOSEL,XX,PSOVDA,PSOSAVE,DA,PS,RXIEN
S PSOSEL=+$P(XQORNOD(0),"=",2) I 'PSOSEL S VALMSG="Invalid selection!",VALMBCK="R" Q
S RXIEN=$G(^TMP("PSOERBT",$J,PSOSEL,"RXIEN")) I 'RXIEN S VALMSG="Invalid selection!",VALMBCK="R" Q
S (PSOVDA,DA)=RXIEN,PS="REJECTMP" I $G(XQY0)="" S XQY0="PSO VIEW"
N LINE,TITLE,PSODFN D DP^PSORXVW
S VALMBCK="R"
Q
;
EXPND ; -- expand code
Q
;
REF ;Screen Refresh
I $D(VALMEVL) F I=1:1:99 D RESTORE^VALM10(I)
D INIT,HDR S VALMBCK="R"
Q
;
ENTRYSEL ; Allows selection of Rx's in the List
N DIR,X,DIRUT,DIROUT,RANGE,I,REC,COMSEG
I '$D(^TMP("PSOERBT",$J,1,"RXIEN")) S VALMSG="There are no entries to be selected!" W $C(7) Q
S DIR("A")="SELECT RX's (1-"_+$O(^TMP("PSOERBT",$J,""),-1)_"): "
S DIR(0)="LA^1:"_+$O(^TMP("PSOERBT",$J,""),-1) W ! D ^DIR I $D(DIRUT)!$D(DIROUT) Q
S RANGE=X
K ^TMP("PSOERSEL",$J)
F I=1:1:$L(RANGE,",") D
. S COMSEG=$P(RANGE,",",I)
. F REC=+COMSEG:1:$S(COMSEG["-":$P(COMSEG,"-",2),1:+COMSEG) D
. . I '$G(^TMP("PSOERBT",$J,REC,"RXIEN")) Q
. . S ^TMP("PSOERSEL",$J,^TMP("PSOERBT",$J,REC,"RXIEN"))=REC
Q
;
IAS ;Include All Status Switch
W ?52,"Please wait..." S PSOALLST=$S($G(PSOALLST):0,1:1),LINE=0 D REF
I 'PSOALLST S VALMBG=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOERBT 15423 printed Aug 26, 2025@22:43:39 Page 2
PSOERBT ;ALB/RM - Handles Multiple eRx CH REQ Submission & Drug Conversion (MbM) ;Jan 16, 2025@12:43:34
+1 ;;7.0;OUTPATIENT PHARMACY;**770**;DEC 16, 1997;Build 145
+2 ;
EN ; main entry point of the menu option
+1 NEW DIR,X,Y,CONVTYPE,BEGFLDT,ENDFLDT,ALLOWSUB,MBMSITE,PSOQUIT,ERXNERX,CHRQTYPE,NOTE2PRV,FROMDRUG,NEWDRUG,VRXSIG,PSOALLST
+2 SET MBMSITE=$SELECT($$GET1^DIQ(59.7,1,102,"I")="MBM":1,1:0)
+3 ;
+4 ;Division Selection
+5 IF '$GET(PSOSITE)
DO ^PSOLSET
IF '$DATA(PSOPAR)
WRITE $CHAR(7),!!,"Pharmacy Division Must be Selected!",!
GOTO EXIT
+6 SET PSNPINST=$$GET1^DIQ(59,PSOSITE,101,"I")
+7 ;
+8 KILL DIR
SET DIR("A")="CHOOSE BATCH CONVERSION TYPE"
+9 SET DIR(0)="S^CR:MULTIPLE ERX CHANGE REQUEST SUBMISSION;DR:VISTA DISPENSE DRUG REPLACEMENT (MbM ONLY)"
+10 SET DIR("?",1)="CR - Use this option to send the same eRx Change Request to the external"
+11 SET DIR("?",2)=" prescribers for multiple VistA Rx's issued within a date range."
+12 SET DIR("?",3)=" "
+13 SET DIR("?",4)="DR - *** Available to Meds-by-Mail only ***"
+14 SET DIR("?",5)=" Use this option to replace the VistA dispense drug for multiple VistA"
+15 SET DIR("?",6)=" Rx's issued within a date range."
+16 SET DIR("?")=" "
+17 DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)
GOTO EXIT
+18 IF Y="DR"
IF 'MBMSITE
WRITE !!,"This option is available for MbM sites only",$CHAR(7)
DO PAUSE^PSOSPMU1
GOTO EXIT
+19 SET CONVTYPE=Y
+20 ;
+21 IF CONVTYPE="DR"
IF '$DATA(^XUSEC("PSNMGR",DUZ))
Begin DoDot:1
+22 WRITE !,"You need to hold the PSNMGR key to access this option."
SET DIR(0)="E"
DO ^DIR
KILL DIR
End DoDot:1
GOTO EXIT
+23 ;
+24 ; Ask for TYPE OF CHANGE REQUEST for Change Request submission
+25 SET PSOQUIT=0
+26 IF CONVTYPE="CR"
Begin DoDot:1
+27 NEW X,Y,DIC,DONE,FROMOI,TOOI,FROMSTRN,TOSTREN,ERXIEN
+28 SET (CHRQTYPE,NOTE2PRV,FROMDRUG,NEWDRUG,RXHASH)=""
+29 KILL DIR
SET DIR("A")="TYPE OF CHANGE REQUEST"
+30 SET DIR(0)="S^1:CHANGE REQUEST FOR SAME DRUG/SIG RX'S;2:DRUG REPLACEMENT FOR SIMILAR VISTA DRUG;3:CHANGE REQUEST W/OUT DRUG SUGGESTION(S)"
+31 SET DIR("?",1)="1 - The software will search for VistA Rx's with the same dispense drug"
+32 SET DIR("?",2)=" and SIG, then it will allow you to send the same eRx Change Request"
+33 SET DIR("?",3)=" for these Rx's. "
+34 SET DIR("?",4)=" "
+35 SET DIR("?",5)="2 - The software will search for VistA Rx's with the same dispense drug"
+36 SET DIR("?",6)=" and will allow you to indicate a new dispense drug that will be used"
+37 SET DIR("?",7)=" as a suggestion for an eRx Change Request that can be sent for these"
+38 SET DIR("?",8)=" Rx's."
+39 SET DIR("?",9)=" "
+40 SET DIR("?",10)="3 - The software will search for VistA Rx's with the same dispense drug,"
+41 SET DIR("?",11)=" then it will allow you to send the same eRx Change Request without a"
+42 SET DIR("?",12)=" a drug suggestion for these Rx's."
+43 SET DIR("?")=" "
+44 DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)
SET PSOQUIT=1
QUIT
+45 SET CHRQTYPE=+Y
End DoDot:1
IF PSOQUIT
GOTO EXIT
+46 ;
+47 ; Change Request for Same Drug/SIG Rx's (option 1) - Addt'l prompt
+48 IF CONVTYPE="CR"
IF +$GET(CHRQTYPE)=1
Begin DoDot:1
+49 WRITE !
KILL DIC
SET DIC="52"
SET DIC(0)="AEMQZV"
SET DIC("A")="VISTA RX #: "
+50 SET (DONE,PSOQUIT)=0
+51 FOR
Begin DoDot:2
+52 ;keep prompting until user enter a valid entry
+53 DO ^DIC
IF $DATA(DTOUT)!$DATA(DUOUT)
SET PSOQUIT=1
QUIT
+54 IF (+Y<1)!(X="")
WRITE !!,"Required!",!,$CHAR(7)
QUIT
+55 SET VRXIEN=+Y
SET ERXIEN=$$ERXIEN^PSOERXUT(VRXIEN)
+56 IF ERXIEN=""
WRITE !," Not an eRx Prescription.",!
QUIT
+57 SET FROMDRUG=$$GET1^DIQ(52,VRXIEN,6,"I")
SET VRXSIG=$$RXSIG^PSOERBT1(VRXIEN)
+58 IF 'FROMDRUG
WRITE !,"There's a problem with the Drug in this Rx.",!
QUIT
+59 IF VRXSIG=""
WRITE !,"There's a problem with the SIG in this Rx.",!
QUIT
+60 SET DONE=1
End DoDot:2
if (DONE!PSOQUIT)
QUIT
+61 IF PSOQUIT
QUIT
End DoDot:1
IF PSOQUIT
GOTO EXIT
+62 ;
+63 ; Drug Replacement for Similar VistA Drug (option 2) - Addt'l prompts
+64 IF CONVTYPE="DR"!((CONVTYPE="CR")&($GET(CHRQTYPE)=2))
Begin DoDot:1
+65 WRITE !
KILL DIC,X,Y
SET DIC="50"
SET DIC(0)="AEMQZI"
SET DIC("A")="FROM VISTA DRUG: "
SET D="B^AQ1"
+66 SET DIC("S")="I ($$OUTPAT^PSOERXA0(+Y))"
+67 SET (DONE,PSOQUIT)=0
+68 FOR
Begin DoDot:2
+69 ;keep prompting until user enter a valid entry
+70 DO MIX^DIC1
IF $DATA(DTOUT)!$DATA(DUOUT)
SET PSOQUIT=1
QUIT
+71 IF (+Y<1)!(X="")
WRITE !!,"Required!",!,$CHAR(7)
QUIT
+72 IF CONVTYPE="CR"
IF $$GETNDC^PSSNDCUT(+Y,$GET(PSOSITE))=""
WRITE !!,"Drug does not have an NDC code!",!,$CHAR(7)
QUIT
+73 SET FROMDRUG=+Y
SET DONE=1
End DoDot:2
if (DONE!PSOQUIT)
QUIT
+74 IF PSOQUIT
QUIT
+75 ;
+76 WRITE !
KILL DIC,X,Y
SET DIC="50"
SET DIC(0)="AEMQZI"
SET DIC("A")="NEW VISTA DRUG: "
+77 SET DIC("S")="I $$ACTIVE^PSOERXA0(+Y),($$OUTPAT^PSOERXA0(+Y)),+Y'=FROMDRUG"
SET D="B^AQ1"
+78 SET (DONE,PSOQUIT)=0
+79 FOR
Begin DoDot:2
+80 ;keep prompting until user enter a valid entry
+81 DO MIX^DIC1
IF $DATA(DTOUT)!$DATA(DUOUT)
SET PSOQUIT=1
QUIT
+82 IF (+Y<1)!(X="")
WRITE !!,"Required!",!,$CHAR(7)
QUIT
+83 IF $$GETNDC^PSSNDCUT(+Y,$GET(PSOSITE))=""
WRITE !!,"Drug does not have an NDC code!",!,$CHAR(7)
QUIT
+84 IF +Y=FROMDRUG
WRITE !!,"Cannot be the same drug!",!,$CHAR(7)
QUIT
+85 SET NEWDRUG=+Y
SET DONE=1
End DoDot:2
if (DONE!PSOQUIT)
QUIT
+86 IF PSOQUIT
QUIT
+87 ;
+88 ; Warnings about the 2 dispense drugs selected
+89 IF $$GET1^DIQ(50,FROMDRUG,2)'=$$GET1^DIQ(50,NEWDRUG,2)
Begin DoDot:2
+90 WRITE !!,"WARNING: Drugs selected belong to different VA Classes:",$CHAR(7)
+91 WRITE !," - ",$$GET1^DIQ(50,FROMDRUG,2)
+92 WRITE !," - ",$$GET1^DIQ(50,NEWDRUG,2)
+93 DO PAUSE^PSOERXUT
End DoDot:2
+94 ; Warnings about the 2 dispense drugs selected
+95 SET FROMOI=$$GET1^DIQ(50,FROMDRUG,2.1,"I")
SET TOOI=$$GET1^DIQ(50,NEWDRUG,2.1,"I")
+96 IF FROMOI'=TOOI
Begin DoDot:2
+97 WRITE !!,"WARNING: Drugs selected belong to different Orderable Items:",$CHAR(7)
+98 WRITE !," - ",$$GET1^DIQ(50,FROMDRUG,2.1)
+99 WRITE !," - ",$$GET1^DIQ(50,NEWDRUG,2.1)
+100 DO PAUSE^PSOERXUT
End DoDot:2
+101 SET FROMSTRN=$$GET1^DIQ(50,FROMDRUG,901)_$$GET1^DIQ(50,FROMDRUG,902)_" "_$$GET1^DIQ(50.7,FROMOI,.02)
+102 SET TOSTREN=$$GET1^DIQ(50,NEWDRUG,901)_$$GET1^DIQ(50,NEWDRUG,902)_" "_$$GET1^DIQ(50.7,TOOI,.02)
+103 IF FROMSTRN'=TOSTREN
Begin DoDot:2
+104 WRITE !!,"WARNING: Drugs selected have different strengths/form:",$CHAR(7)
+105 WRITE !," - ",FROMSTRN
+106 WRITE !," - ",TOSTREN
+107 DO PAUSE^PSOSPMU1
End DoDot:2
End DoDot:1
IF PSOQUIT
GOTO EXIT
+108 ;
+109 ; Change Request w/out Drug Suggestion(s) (option 3) - Addt'l prompt
+110 IF CONVTYPE="CR"
IF +$GET(CHRQTYPE)=3
Begin DoDot:1
+111 WRITE !
KILL DIC
SET DIC="50"
SET DIC(0)="AEMQZI"
SET DIC("A")="VISTA DRUG: "
+112 SET DIC("S")="I $$OUTPAT^PSOERXA0(+Y)"
SET D="B^AQ1"
+113 SET (DONE,PSOQUIT)=0
+114 FOR
Begin DoDot:2
+115 ;keep prompting until user enter a valid entry
+116 DO MIX^DIC1
IF $DATA(DTOUT)!$DATA(DUOUT)
SET (DONE,PSOQUIT)=1
QUIT
+117 IF (+Y<1)!(X="")
WRITE !!,"Required!",!,$CHAR(7)
QUIT
+118 IF $$GETNDC^PSSNDCUT(+Y,$GET(PSOSITE))=""
WRITE !!,"Drug does not have an NDC code!",!,$CHAR(7)
QUIT
+119 SET FROMDRUG=+Y
SET DONE=1
End DoDot:2
if DONE
QUIT
End DoDot:1
IF PSOQUIT
GOTO EXIT
+120 ;
+121 ; - Ask for FROM FILL DATE
+122 SET %DT(0)=$$FMADD^XLFDT(DT,-366)
SET %DT="AEP"
SET %DT("A")="BEGIN ISSUE DATE: "
SET %DT("B")=$$FMTE^XLFDT($$FMADD^XLFDT(DT,-366),"2Y")
+123 WRITE !
DO ^%DT
IF Y<0!($DATA(DTOUT))
GOTO EXIT
+124 SET BEGFLDT=Y\1-.00001
+125 ;
+126 ; - Ask for END FILL DATE
+127 SET %DT(0)=BEGFLDT+1\1
SET %DT("A")="END ISSUE DATE: "
SET %DT("B")=$$FMTE^XLFDT(DT,"2Y")
+128 WRITE !
DO ^%DT
IF Y<0!($DATA(DTOUT))
GOTO EXIT
+129 SET ENDFLDT=Y\1+.99999
+130 ;
+131 ; Ask for the type of prescription (eRx or Non-eRx)
+132 SET ERXNERX=""
SET PSOQUIT=0
+133 IF CONVTYPE="DR"
Begin DoDot:1
+134 KILL DIR
SET DIR("A")="PRESCRIPTION TYPE (ERX/NON-ERX/BOTH)"
SET DIR("B")="B"
+135 SET DIR(0)="SO^E:ERX PRESCRIPTIONS ONLY;N:NON-ERX PRESCRIPTIONS ONLY;B:BOTH"
+136 SET DIR("?")=" "
SET DIR("?",1)=" E - eRx Prescriptions only"
+137 SET DIR("?",2)=" N - Non-eRx (Backdoor and CPRS) Prescriptions only"
+138 SET DIR("?",2)=" B - Both, eRx and non-eRx prescriptions"
+139 DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)
SET PSOQUIT=1
+140 SET ERXNERX=Y
End DoDot:1
IF PSOQUIT
GOTO EXIT
+141 ;
+142 ; Ask if the Rx should be included based on the Substitution being allowed or not
+143 SET ALLOWSUB=""
SET PSOQUIT=0
+144 IF CONVTYPE="CR"!(ERXNERX="E")!(ERXNERX="B")
Begin DoDot:1
+145 KILL DIR
SET DIR("A")="SUBSTITUTION (eRx ONLY)"
SET DIR("B")="B"
+146 SET DIR(0)="SO^A:SUBSTITUTION ALLOWED;N:SUBSTITUTION NOT ALLOWED;B:BOTH"
+147 SET DIR("?",1)="Only applies to eRx prescriptions"
+148 SET DIR("?",2)=""
+149 SET DIR("?",3)=" A - eRx's w/ Substitution allowed only (NO PRODUCT SELECTION INDICATED)"
+150 SET DIR("?",4)=" N - eRx's w/ Substitution NOT allowed only (SUBS. NOT ALLOWED BY PRESCRIBER)"
+151 SET DIR("?")=" B - Both, include all"
+152 DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)
SET PSOQUIT=1
+153 SET ALLOWSUB=Y
End DoDot:1
IF PSOQUIT
GOTO EXIT
+154 ;
+155 DO EN^VALM("PSO ERX BATCH ERX CHANGE")
+156 ;
+157 GOTO EXIT
+158 QUIT
+159 ;
LMHDR ; Menu Protocol Header Code
+1 DO SHOW^VALM
DO HDR
+2 SET XQORM("#")=$ORDER(^ORD(101,"B","PSO ERX BATCH CHANGE REQUEST SELECT",""))_"^1:"_VALMCNT
+3 SET XQORM("??")="D HELP^VALM2,HDR^PSOERBT"
+4 QUIT
+5 ;
HDR ; Listman Header Code
+1 NEW HDR,I,DRUG,SIG,DOSE,HIGH,NORM,ERXIEN
+2 ;
+3 SET VALM("TITLE")=$SELECT(CONVTYPE="CR":"Batch eRx CH REQ Submission",1:"Dispense Drug Replacement")
+4 SET HIGH=$GET(IOINHI)
SET NORM=$GET(IOINORM)
+5 SET HDR="DATE RANGE: "_HIGH_$$FMTE^XLFDT($GET(BEGFLDT)+.01\1,"2Z")_NORM
+6 SET HDR=HDR_" - "_HIGH_$$FMTE^XLFDT($GET(ENDFLDT)\1,"2Z")_NORM
+7 SET HDR=HDR_" SUBS: "_HIGH_$SELECT(ALLOWSUB="A":"ALLOWED ONLY",ALLOWSUB="N":"NOT ALLOWED ONLY",ALLOWSUB="B":"ALLOWED & NOT ALLOWED",1:"N/A")_NORM
+8 SET HDR=HDR_$JUSTIFY("RX COUNT: "_HIGH_$SELECT('$ORDER(^TMP("PSOERBT",$JOB,0)):0,1:VALMCNT)_NORM,$SELECT(ALLOWSUB="A":34,ALLOWSUB="N":30,ALLOWSUB="B":25,1:43))
+9 DO INSTR^VALM1(HDR,1,2)
+10 ;
+11 ; eRx CH REQUEST header
IF CONVTYPE="CR"
Begin DoDot:1
+12 IF CHRQTYPE=1
Begin DoDot:2
+13 SET DRUG=$$GET1^DIQ(52,FROMDRUG,6,"I")
+14 SET HDR="VISTA DRUG: "_HIGH_$EXTRACT($$GET1^DIQ(50,FROMDRUG,.01),1,40)_" (CMOP ID: "_$$GET1^DIQ(50,FROMDRUG,27)_")"_NORM
DO INSTR^VALM1(HDR,1,3)
+15 SET SIG=VRXSIG
SET HDR="SIG: "_HIGH_$EXTRACT(SIG,1,75)_NORM
DO INSTR^VALM1(HDR,1,4)
+16 SET HDR=$EXTRACT(SIG,76,999)
+17 IF HDR'=""
SET HDR=HIGH_$SELECT($LENGTH(HDR)<55:HDR,1:$EXTRACT(HDR,1,51)_"...")_NORM
DO INSTR^VALM1(HDR,1,5)
End DoDot:2
+18 IF CHRQTYPE=2
Begin DoDot:2
+19 SET HDR="FROM VISTA DRUG: "_HIGH_$EXTRACT($$GET1^DIQ(50,FROMDRUG,.01),1,40)_" (CMOP ID: "_$$GET1^DIQ(50,FROMDRUG,27)_")"_NORM
DO INSTR^VALM1(HDR,1,3)
+20 SET HDR=" NEW VISTA DRUG: "_HIGH_$EXTRACT($$GET1^DIQ(50,NEWDRUG,.01),1,40)_" (CMOP ID: "_$$GET1^DIQ(50,NEWDRUG,27)_")"_NORM
DO INSTR^VALM1(HDR,1,4)
End DoDot:2
+21 IF CHRQTYPE=3
Begin DoDot:2
+22 SET HDR="VISTA DRUG: "_HIGH_$EXTRACT($$GET1^DIQ(50,FROMDRUG,.01),1,40)_" (CMOP ID: "_$$GET1^DIQ(50,FROMDRUG,27)_")"_NORM
DO INSTR^VALM1(HDR,1,3)
End DoDot:2
End DoDot:1
+23 ; VistA Drug Replacement header
IF '$TEST
Begin DoDot:1
+24 SET HDR="FROM VISTA DRUG: "_HIGH_$$GET1^DIQ(50,FROMDRUG,.01)_" (CMOP ID: "_$$GET1^DIQ(50,FROMDRUG,27)_")"_NORM
DO INSTR^VALM1(HDR,1,3)
+25 SET HDR=" NEW VISTA DRUG: "_HIGH_$$GET1^DIQ(50,NEWDRUG,.01)_" (CMOP ID: "_$$GET1^DIQ(50,NEWDRUG,27)_")"_NORM
DO INSTR^VALM1(HDR,1,4)
+26 SET HDR="ERX/NON-ERX : "_HIGH_$SELECT(ERXNERX="E":"ERX ONLY",ERXNERX="N":"NON-ERX ONLY",1:"BOTH")_NORM
DO INSTR^VALM1(HDR,1,5)
End DoDot:1
+27 ;
+28 SET HDR="DAY"
SET $EXTRACT(HDR,5)="REF"
SET $EXTRACT(HDR,9)="LAST"
SET $EXTRACT(HDR,18)="LAST CH "
+29 DO INSTR^VALM1($GET(IORVON)_HDR_NORM,56,5)
+30 SET HDR="#"
SET $EXTRACT(HDR,6)="VISTA RX #"
SET $EXTRACT(HDR,21)="PATIENT"
SET $EXTRACT(HDR,48)="STA"
SET $EXTRACT(HDR,52)="QTY"
SET $EXTRACT(HDR,56)="SUP"
SET $EXTRACT(HDR,60)="REM"
+31 SET $EXTRACT(HDR,64)="FILL"
SET $EXTRACT(HDR,73)="REQUEST"
SET $EXTRACT(HDR,81)=""
+32 DO INSTR^VALM1($GET(IORVON)_HDR_NORM,1,6)
+33 SET XQORM("??")="D HELP^VALM2,HDR^PSOERBT"
+34 QUIT
+35 ;
INIT ; -- init variables and list array
+1 NEW I,HIGHLN,HIGUNDLN,REVLN,BLINKLN,PSOERBT,BFLDT,RXIEN,ISSUEDT,RXIEN
+2 SET VALMBG=1
SET LINE=0
KILL ^TMP("PSOERBTS",$JOB),^TMP("PSOERBT",$JOB)
+3 ; - Resetting list to NORMAL video attributes
DO RESET^PSOERUT0()
+4 ;
+5 WRITE !!,"Please wait..."
+6 SET BFLDT=BEGFLDT
SET LINE=0
+7 FOR
SET BFLDT=$ORDER(^PSRX("ADL",BFLDT))
if BFLDT=""
QUIT
Begin DoDot:1
+8 SET RXIEN=""
FOR
SET RXIEN=$ORDER(^PSRX("ADL",BFLDT,FROMDRUG,RXIEN))
if RXIEN=""
QUIT
Begin DoDot:2
+9 SET ISSUEDT=$$GET1^DIQ(52,RXIEN,1,"I")
IF $DATA(^TMP("PSOERBTS",$JOB,ISSUEDT,RXIEN))
QUIT
+10 ;issue date vs end date check
IF ISSUEDT>ENDFLDT
QUIT
+11 IF FROMDRUG'=$$GET1^DIQ(52,RXIEN,6,"I")
QUIT
+12 SET ERXIEN=$$ERXIEN^PSOERXUT(RXIEN)
+13 ;substitution check
IF ERXIEN
IF ALLOWSUB'="B"
IF $$GET1^DIQ(52.49,ERXIEN,5.8,"I")'=$SELECT(ALLOWSUB="A":0,1:1)
QUIT
+14 ;Not an eRx prescription
IF CONVTYPE="CR"
IF 'ERXIEN
QUIT
+15 ;rx status check (ACTIVE,HOLD,SUSPENDED)
IF '$GET(PSOALLST)
IF ",0,3,5,"'[(","_$$GET1^DIQ(52,RXIEN,100,"I")_",")
QUIT
+16 IF CONVTYPE="CR"
IF CHRQTYPE=1
IF VRXSIG'=$$RXSIG^PSOERBT1(RXIEN)
QUIT
+17 IF CONVTYPE="DR"
IF ERXNERX="N"
IF ERXIEN
QUIT
+18 IF CONVTYPE="DR"
IF ERXNERX="E"
IF 'ERXIEN
QUIT
+19 SET ^TMP("PSOERBTS",$JOB,ISSUEDT,RXIEN)=ERXIEN
End DoDot:2
End DoDot:1
+20 ;
+21 SET (ISSUEDT,RXIEN)=""
+22 FOR
SET ISSUEDT=$ORDER(^TMP("PSOERBTS",$JOB,ISSUEDT))
if 'ISSUEDT
QUIT
Begin DoDot:1
+23 FOR
SET RXIEN=$ORDER(^TMP("PSOERBTS",$JOB,ISSUEDT,RXIEN))
if 'RXIEN
QUIT
Begin DoDot:2
+24 DO ADRX2LST(RXIEN,+$GET(^TMP("PSOERBTS",$JOB,ISSUEDT,RXIEN)))
End DoDot:2
End DoDot:1
+25 KILL ^TMP("PSOERBTS",$JOB)
+26 ;
+27 IF '$ORDER(^TMP("PSOERBT",$JOB,0))
Begin DoDot:1
+28 FOR I=1:1:6
SET ^TMP("PSOERBT",$JOB,I,0)=""
+29 SET ^TMP("PSOERBT",$JOB,7,0)=" There were no records found that met the above criteria."
SET HIGHLN(7,4)=80
+30 ; Changes the Video Attributes for the list
DO VIDEO^PSOERUT0()
+31 SET VALMCNT=1
End DoDot:1
QUIT
+32 ;
+33 ; - Saving NORMAL video attributes to be reset later
+34 IF LINE>$GET(LASTLINE)
Begin DoDot:1
+35 FOR I=($GET(LASTLINE)+1):1:LINE
DO SAVE^VALM10(I)
+36 SET LASTLINE=LINE
End DoDot:1
+37 ; Changes the Video Attributes for the list
DO VIDEO^PSOERUT0()
+38 SET VALMCNT=$ORDER(^TMP("PSOERBT",$JOB,""),-1)
+39 QUIT
+40 ;
ADRX2LST(RXIEN,ERXIEN) ;Add the prescription to the list for display
+1 ;Input: ERXIEN - Pointer to the PRESCRIPTION file (#52)
+2 ; (o)RXIEN - Pointer to the ERX HOLDING QUEUE file (#52.49)
+3 NEW STA,STAT,PSOCMOP,LASTCHREQ,VISTARX,LASTFLDT,PTNAME,NUMREFS,PROVIDER,QUANTITY,DAYSUP
+4 SET STA="A^N^R^H^N^S^^^^^^E^DC^^DP^DE^HP^P^"
+5 SET PSOCMOP=""
+6 SET LASTCHREQ=$$LSTCHREQ^PSOERBT2(ERXIEN)
+7 SET VISTARX=$$GET1^DIQ(52,RXIEN,.01,"E")
+8 ;determine if rx is cmop dispense/transmitted, etc.
SET PSOCMOP=$$ISCMOPD^PSOERBT2(RXIEN)
+9 SET STAT=$PIECE(STA,"^",$$GET1^DIQ(52,RXIEN,100,"I")+1)
Begin DoDot:1
+10 IF $GET(^PSRX(RXIEN,"DDSTA"))]""
SET STAT="DD"
QUIT
+11 IF $GET(^PSRX(RXIEN,"PARK"))
IF STA="A"
SET STAT="AP"
End DoDot:1
+12 SET STAT=$SELECT($PIECE($GET(^PSRX(RXIEN,7)),"^")=1:"DA",$PIECE($GET(^PSRX(RXIEN,7)),"^")=2:"DF",1:STAT)
+13 SET STAT=STAT_PSOCMOP
SET DAYSUP=$$GET1^DIQ(52,RXIEN,8)
+14 SET LASTFLDT=$$RXFLDT^PSOBPSUT(RXIEN)
SET PTNAME=$$GET1^DIQ(52,RXIEN,2,"E")
SET PROVIDER=$$GET1^DIQ(52,RXIEN,4,"E")
+15 SET QUANTITY=+$$GET1^DIQ(52,RXIEN,7,"I")
SET NUMREFS=+$$GET1^DIQ(52,RXIEN,9,"I")-$$LSTRFL^PSOBPSU1(RXIEN)
+16 SET LINE=LINE+1
SET LINETXT=LINE_"."
+17 SET $EXTRACT(LINETXT,6)=$SELECT(ERXIEN:"& ",1:"")_VISTARX
SET $EXTRACT(LINETXT,21)=$EXTRACT(PTNAME,1,26)
SET $EXTRACT(LINETXT,48)=STAT
SET $EXTRACT(LINETXT,52)=$JUSTIFY(QUANTITY,3)
+18 SET $EXTRACT(LINETXT,56)=$JUSTIFY(DAYSUP,3)
SET $EXTRACT(LINETXT,60)=$JUSTIFY(NUMREFS,3)
SET $EXTRACT(LINETXT,64)=$TRANSLATE($$FMTE^XLFDT(LASTFLDT,"2Z"),"/","-")
+19 SET $EXTRACT(LINETXT,73)=$TRANSLATE($$FMTE^XLFDT($$LSTCHREQ^PSOERBT2(ERXIEN),"2Z"),"/","-")
+20 SET ^TMP("PSOERBT",$JOB,LINE,0)=LINETXT
+21 SET ^TMP("PSOERBT",$JOB,LINE,"RXIEN")=RXIEN
+22 QUIT
+23 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 SET VALMBCK="R"
+3 QUIT
+4 ;
EXIT ; -- exit code
+1 KILL ^TMP("PSOERBT",$JOB),^TMP("PSOERSEL",$JOB)
+2 DO CLEAR^VALM1
+3 DO FULL^VALM1
+4 QUIT
+5 ;
SEL ;Process selection of one entry
+1 NEW PSOSEL,XX,PSOVDA,PSOSAVE,DA,PS,RXIEN
+2 SET PSOSEL=+$PIECE(XQORNOD(0),"=",2)
IF 'PSOSEL
SET VALMSG="Invalid selection!"
SET VALMBCK="R"
QUIT
+3 SET RXIEN=$GET(^TMP("PSOERBT",$JOB,PSOSEL,"RXIEN"))
IF 'RXIEN
SET VALMSG="Invalid selection!"
SET VALMBCK="R"
QUIT
+4 SET (PSOVDA,DA)=RXIEN
SET PS="REJECTMP"
IF $GET(XQY0)=""
SET XQY0="PSO VIEW"
+5 NEW LINE,TITLE,PSODFN
DO DP^PSORXVW
+6 SET VALMBCK="R"
+7 QUIT
+8 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
REF ;Screen Refresh
+1 IF $DATA(VALMEVL)
FOR I=1:1:99
DO RESTORE^VALM10(I)
+2 DO INIT
DO HDR
SET VALMBCK="R"
+3 QUIT
+4 ;
ENTRYSEL ; Allows selection of Rx's in the List
+1 NEW DIR,X,DIRUT,DIROUT,RANGE,I,REC,COMSEG
+2 IF '$DATA(^TMP("PSOERBT",$JOB,1,"RXIEN"))
SET VALMSG="There are no entries to be selected!"
WRITE $CHAR(7)
QUIT
+3 SET DIR("A")="SELECT RX's (1-"_+$ORDER(^TMP("PSOERBT",$JOB,""),-1)_"): "
+4 SET DIR(0)="LA^1:"_+$ORDER(^TMP("PSOERBT",$JOB,""),-1)
WRITE !
DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)
QUIT
+5 SET RANGE=X
+6 KILL ^TMP("PSOERSEL",$JOB)
+7 FOR I=1:1:$LENGTH(RANGE,",")
Begin DoDot:1
+8 SET COMSEG=$PIECE(RANGE,",",I)
+9 FOR REC=+COMSEG:1:$SELECT(COMSEG["-":$PIECE(COMSEG,"-",2),1:+COMSEG)
Begin DoDot:2
+10 IF '$GET(^TMP("PSOERBT",$JOB,REC,"RXIEN"))
QUIT
+11 SET ^TMP("PSOERSEL",$JOB,^TMP("PSOERBT",$JOB,REC,"RXIEN"))=REC
End DoDot:2
End DoDot:1
+12 QUIT
+13 ;
IAS ;Include All Status Switch
+1 WRITE ?52,"Please wait..."
SET PSOALLST=$SELECT($GET(PSOALLST):0,1:1)
SET LINE=0
DO REF
+2 IF 'PSOALLST
SET VALMBG=1
+3 QUIT
