PSOSPML7 ;BIRM/MFR - Resend a Group of Selected Prescriptions ;10/10/12
;;7.0;OUTPATIENT PHARMACY;**625,630**;DEC 1997;Build 26
;
;
ASK ; MANUAL BATCH EXPORT
;RETRIEVE FILTERS FROM USER
D FULL^VALM1 S VALMBCK="R"
N %DT,DIR,DIRUT,X,DIC,DTOUT,DUOUT,BEGINDT,ENDDT,PSOERROR
N RECTYPE,STATE,QUIT,ARRAY,TAG,FILTER
;
; - Selection of STATE
W ! S DIC("A")="STATE: ",DIC("S")="I $D(^PS(58.41,+Y,0))",DIC="^DIC(5,"
S DIC("B")=$$GET1^DIQ(5,+$O(^PS(58.41,0)),.01)
S DIC(0)="AEQMZ" D ^DIC I X="^"!(Y<0) Q
S STATE=+Y
BEGDT ;
; - Ask for Start DATE
; Note: The legislation allowing VA to report was published on 02/11/2013
N XDT S XDT=$$FMADD^XLFDT(DT,-1)
S %DT(0)=3130211,%DT="AEP",%DT("A")="Export Rx's Starting with RELEASE DATE (2/11/13 to "_$$FMTE^XLFDT(XDT,2)_"): "
W ! D ^%DT
I X="" W !!?5,"Starting RELEASE DATE is required or enter '^' to exit.",! G BEGDT
I Y<0!($D(DTOUT)) Q
I (Y=DT)!(Y>DT) W !!?5,"Only past dates are allowed." D PAUSE^PSOSPMU1 G BEGDT
S BEGINDT=Y
;
W !!?5,"Prescriptions released today will be included in the next scheduled batch."
;
ENDDT ;
; - Ask for End DATE
K %DT S %DT(0)=BEGINDT\1,%DT="AEP",%DT("B")="TODAY-1",%DT("A")="Export Rx's Ending with RELEASE DATE ("_$$FMTE^XLFDT(BEGINDT,2)_" to "_$$FMTE^XLFDT(XDT,2)_"): "
W ! D ^%DT I Y<0!($D(DTOUT)) Q
I (Y=DT)!(Y>DT) W !!?5,"The latest end date permitted is TODAY-1 (yesterday)." D PAUSE^PSOSPMU1 G ENDDT
S ENDDT=Y
;
S QUIT=0,FILTER="NC"
D Q:QUIT
. K DIR S DIR("A")="Filter Selection"
. S DIR(0)="S^PA:Patient;PR:Prescriber;DR:Drug;DV:Division;RX:Prescription;NC:No Criteria"
. S DIR("L",1)="Select prescriptions by one of the following criteria:"
. S DIR("L",2)=" "
. S DIR("L",3)=" PA Patient"
. S DIR("L",4)=" PR Prescriber"
. S DIR("L",5)=" DR Drug"
. S DIR("L",6)=" DV Division"
. S DIR("L",7)=" RX Prescription"
. S DIR("L")=" NC No criteria (unfiltered). All Rx's within the date range selected."
. D ^DIR I $D(DUOUT)!($D(DIRUT)) K DIRUT,DUOUT,DIR S QUIT=1 Q
. S FILTER=Y
;
K ARRAY
S TAG=$S(FILTER="PA":"PATSEL",FILTER="PR":"PRESCSEL",FILTER="DR":"DRGSEL",FILTER="DV":"DIVSEL",FILTER="RX":"RXSEL",1:"NOCRITERIA")
D @TAG
I TAG'="NOCRITERIA",'$O(ARRAY(0)) Q
D RTSEL
Q:QUIT
; create and export the batch passing ARRAY which will be the iens of patients, prescribers, drugs, divisions, or prescriptions.
; If no filter criteria was selected then the ARRAY variable would equal "NC"
D EXPORT^PSOSPML1(STATE,BEGINDT,ENDDT,"RL",RECTYPE,.ARRAY)
Q
;
NOCRITERIA ;
; No criteria was selected. All RXs will be sent within the given date range.
S ARRAY="NC"
Q
;
PATSEL ;
; - Selection of PATIENTS
N DIC,X,I,Y
N DIR,DTOUT,DUOUT,DIROUT
S DIC(0)="QEAM",DIC("A")="Select PATIENT: "
W !!,"You may enter one or more PATIENTS in succession.",!
F D PATLK S Y=PSOPTLK Q:+Y<1 S ARRAY(+Y)="" K PSOPTLK S DIC("A")="Another PATIENT: "
I $G(PSOPTLK)="^" S QUIT=1 K ARRAY
I $O(ARRAY(0)) S ARRAY="PA"
Q
;
PRESCSEL ;
; - Selection of PRESCRIBERS
N DIC,X,I,Y,DTOUT,DUOUT,DIRUT,DIROUT
S DIC="^VA(200,",DIC(0)="QEAM"
S DIC("W")="W "" "",$P(^(""PS""),""^"",9)"
S DIC("A")="Select PRESCRIBER: "
S DIC("S")="I $D(^(""PS"")),$P(^(""PS""),""^""),$S('$P(^(""PS""),""^"",4):1,1:$P(^(""PS""),""^"",4)'<DT)"
W !!,"You may enter one or more PRESCRIBERS in succession.",!
F D ^DIC D Q:QUIT
. I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) K ARRAY S QUIT=1 Q
. I +Y<1&'$O(ARRAY(0)) W !!,"Please enter at least one PRESCRIBER or '^' to exit.",! Q
. I +Y<1 S QUIT=1 Q
. S ARRAY(+Y)=""
. S DIC("A")="Another PRESCRIBER: "
I $O(ARRAY(0)) S ARRAY="PR"
Q
;
DIVSEL ; - Division selection (one, multiple or ALL)
N DIC,DTOUT,DUOUT,DIROUT,Y,X,XX
W !!,"You may enter one or more DIVISIONS in succession.",!
I '$G(DT) N DT S DT=$$NOW^XLFDT()
S DIC("S")="I $S('$D(^PS(59,+Y,""I"")):1,'^(""I""):1,DT'>^(""I""):1,1:0)"
S DIC="^PS(59,",DIC(0)="QEZAM",DIC("A")="Select DIVISION: "
F D ^DIC D Q:QUIT
. I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) K ARRAY S QUIT=1 Q
. I +Y<1&'$O(ARRAY(0)) W !!,"Please enter at least one DIVISION or '^' to exit.",! Q
. I +Y<1 S QUIT=1 Q
. S ARRAY(+Y)=""
. S DIC("A")="Another DIVISION: "
I $O(ARRAY(0)) S ARRAY="DV"
Q
;
DRGSEL ;
; Prompt for drug
N DIC,Y,DTOUT,DUOUT,DIRUT,DIROUT
S DIC(0)="AEMQ",DIC=50
S DIC("S")="I $$CSDRUG^PSOSPML7(Y)"
S DIC("A")="Select DRUG GENERIC NAME: "
W !!,"You may enter one or more DRUGS in succession.",!
F D ^DIC D Q:QUIT
. I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) K ARRAY S QUIT=1 Q
. I +Y<1&'$O(ARRAY(0)) W !!,"Please enter at least one DRUG or '^' to exit.",! Q
. I +Y<1 S QUIT=1 Q
. S ARRAY(+Y)=""
. S DIC("A")="Another DRUG: "
I $O(ARRAY(0)) S ARRAY="DR"
Q
;
RXSEL ;
; - Selection of prescriptions - Prescription prompt
N DIR,X,Y,FILLNUM,SCREEN,DTOUT,DUOUT,DIROUT
W !!,"You may enter one or more PRESCRIPTIONS in succession.",!
F D RXSEL1 Q:QUIT
I $O(ARRAY(0)) S ARRAY="RX"
Q
RXSEL1 ;
s DIR("A")=$S('$O(ARRAY(0)):"Select PRESCRIPTION: ",1:"Another PRESCRIPTION: ")
S DIR(0)="FAO^1:30",(DIR("?"),DIR("??"))="^D HLP^PSOSPML7"
D ^DIR
I $D(DTOUT)!$D(DUOUT)!$D(DIROUT) K ARRAY S QUIT=1 Q
I X=""&'$O(ARRAY(0)) W !!,"Please enter at least one PRESCRIPTION or '^' to exit.",! Q
I X="" S QUIT=1 Q
S X=$$UP^XLFSTR(X),QUIT=0
I $E(X,1,2)'="E." S RXIEN=+$$RXLKP(X) I RXIEN<0 Q
I $E(X,1,2)="E." D I QUIT S QUIT=0 Q
. I $L(X)'=9 W !?5,"The ECME# must be 7 digits long!",$C(7) S QUIT=1 Q
. S RXIEN=+$$RXNUM^PSOBPSU2($E(X,3,9)) I RXIEN<0 W " ??" S QUIT=1
S FILLNUM=$$RXFILL^PSOSPMU2(RXIEN) I FILLNUM="^" S QUIT=1 Q
S SCREEN=$$SCREEN^PSOSPMUT(RXIEN,FILLNUM)
I +SCREEN D Q:$P(SCREEN,"^",3)="E"
. W !!?1,$S($P(SCREEN,"^",3)="E":"ERROR",1:"WARNING"),": ",$P(SCREEN,"^",2),$C(7) D PAUSE^PSOSPMU1
I '$$RXRLDT^PSOBPSUT(RXIEN,FILLNUM) D Q
. W !!?1,"Cannot select. Prescription not RELEASED. " D PAUSE^PSOSPMU1
I '$D(^PS(58.42,"ARX",RXIEN,FILLNUM)) D Q
. W !!?1,"Cannot select. Prescription not previously in a transmission batch. " D PAUSE^PSOSPMU1
S ARRAY(RXIEN,FILLNUM)=""
;
Q
;
FILTER(LIST,RXIEN,FILL) ; Filter Rx Fills based on User Entered Filter Criteria
; Input: FILTER - List of Filter(s) to be screened
;(LIST="PR" or "DR" or "PA" or "NC" or "RX", LIST(PROV IEN) or (LIST(PAT IEN) or LIST(RXIEN,FILL)
; (r) RX - Rx IEN (#52)
; (r) RFL - Refill #
;
; Output: 1 - Filter (Skip) | 0 - Don't Filter (Include)
N RXRES
S RXRES=0
I LIST="NC" Q RXRES
I LIST="RX",'$D(LIST(RXIEN,FILL)) S RXRES=1 Q RXRES
I LIST="PR" D Q RXRES ;provider/prescriber filter
. I '$D(LIST($$RXPRV(RXIEN,FILL))) S RXRES=1 Q
. I '$D(^PS(58.42,"ARX",RXIEN,FILL)) S RXRES=1 Q ; fill not in a previously transmitted batch
I LIST="DR" D Q RXRES
. I '$D(LIST($$GET1^DIQ(52,RXIEN,6,"I"))) S RXRES=1 Q
. I '$D(^PS(58.42,"ARX",RXIEN,FILL)) S RXRES=1 Q ; fill not in a previously transmitted batch
I LIST="PA" D Q RXRES
. I '$D(LIST($$GET1^DIQ(52,RXIEN,2,"I"))) S RXRES=1 Q
. I '$D(^PS(58.42,"ARX",RXIEN,FILL)) S RXRES=1 Q ; fill not in a previously transmitted batch
I LIST="DV" D Q RXRES
. I '$D(LIST($$RXSITE^PSOBPSUT(RXIEN,FILL))) S RXRES=1 Q
. I '$D(^PS(58.42,"ARX",RXIEN,FILL)) S RXRES=1 Q ; fill not in a previously transmitted batch
I LIST="ARX",$D(^PS(58.42,"ARX",RXIEN,FILL)),$$CHKST^PSOSPML8(RXIEN,FILL,$G(LIST("STATE"))) Q 1
Q RXRES
;
RXPRV(RXIEN,FILL) ; Returns the Rx Fill Provider IEN
; Input: (r) RXIEN - Rx IEN (#52)
; (o) FILL - Refill # (Default: most recent - except Partial)
; Note: "P1", "P2"... represent partial fills
; Output: RXPRV - Rx Fill Provider IEN
N RXPRV
I '$G(RXIEN) Q ""
I '$D(FILL) S FILL=$$LSTRFL(RXIEN)
I FILL S RXPRV=$$GET1^DIQ(52.1,FILL_","_RXIEN,15,"I")
I FILL["P" S RXPRV=$$GET1^DIQ(52.2,+$E(FILL,2,9)_","_RXIEN,6,"I")
I '$G(RXPRV) S RXPRV=$$GET1^DIQ(52,RXIEN,4,"I")
Q RXPRV
;
LSTRFL(RX) ; - Returns the latest fill for the Rx
; Input: (r) RX - Rx IEN (#52)
;Output: LSTRFL - Most recent refill #
N I,LSTRFL
S (I,LSTRFL)=0 F S I=$O(^PSRX(RX,1,I)) Q:'I S LSTRFL=I
Q LSTRFL
;
;
HLP ; Help Text for the VIEW PRESCRIPTION prompt
W !," A prescription number or ECME number may be entered. To look-up a"
W !," prescription by the ECME number, please enter ""E."" followed by the ECME"
W !," number with or without any leading zeros."
D LKP("?")
Q
;
LKP(INPUT) ; - Performs Lookup on the PRESCRIPTION file
N DIC,X,Y
S DIC="^PSRX(",DIC(0)="QE",D="B",X=INPUT
S DIC("S")="I $$CSRX^PSOSPML7(Y)"
D IX^DIC
Q Y
;
RXLKP(RXNUM) ; - Peforms Lookup on the PRESCRIPTION file
N DIC,X,Y,D
S DIC="^PSRX(",DIC(0)="QE",D="B",X=RXNUM
D IX^DIC
Q Y
;
CSRX(RXIEN) ; Controlled Substance Rx?
; Input: RXIEN - PRESCRIPTION file (#52) pointer
;Output: $$CS - 1:YES / 0:NO
N DRGIEN,DEA
S DRGIEN=$P($G(^PSRX(RXIEN,0)),U,6) I 'DRGIEN Q 0
S DEA=$P($G(^PSDRUG(DRGIEN,0)),U,3) ; retrieve DEA special handling code(s)
I (DEA'["0"),(DEA'["M"),(DEA["2")!(DEA["3")!(DEA["4")!(DEA["5") Q 1
Q 0
;
RTSEL ;
; - Selection of record type
S RECTYPE="N",QUIT=0
D Q:QUIT
. K DIR S DIR("A")="Record Type"
. S DIR("L",1)="Enter the type of record to be sent for released prescription fills:"
. S DIR("L",2)=" "
. S DIR(0)="S^N:NEW;R:REVISE"
. S DIR("L",3)=" N NEW"
. S DIR("L")=" R REVISE"
. S DIR("?",1)="NEW is used for records that were rejected and NOT sent to the State database."
. S DIR("?")="REVISE is used only for records that were rejected but were still sent to the State database."
. S DIR("B")="NEW" D ^DIR I $D(DUOUT)!($D(DIRUT)) K DIRUT,DUOUT,DIR S QUIT=1 Q
. S RECTYPE=Y
Q
CSDRUG(IEN) ;Controlled Substance drug?
; Input: DRGIEN - DRUG file (#50) pointer
;Output: $$CS - 1:YES / 0:NO
N DEA
Q:'IEN 0
S DEA=$P($G(^PSDRUG(IEN,0)),U,3)
I (DEA'["0"),(DEA'["M"),(DEA["2")!(DEA["3")!(DEA["4")!(DEA["5") Q 1
Q 0
;
PATLK ;Entry point - Prompts for Patient, Prescription Number or Barcode
;
; Input - DIC(0) & DIC("A") [Optional]
; Used by DIR if defined by the calling routine.
;
; Output - PSOPTLK [Processed user response]
;
K PSOPTLK,PAGE
S DIR(0)="FOU"_$S($D(DIC("A")):"A",1:"")_"^^K:$$PATVAL^PSOPATLK() X"
S DIR("A")=$S($D(DIC("A")):DIC("A"),1:"Select PATIENT NAME")
S (DIR("?"),DIR("??"))="^D PATHLP^PSOPATLK"
D ^DIR
I $D(DTOUT)!$D(DUOUT)!$D(DIROUT) S Y="^"
I Y=""&'$O(ARRAY(0)) W !!,"Please enter at least one PATIENT or '^' to exit.",! G PATLK
M PSOPTLK=Y
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOSPML7 10651 printed Oct 16, 2024@18:35:46 Page 2
PSOSPML7 ;BIRM/MFR - Resend a Group of Selected Prescriptions ;10/10/12
+1 ;;7.0;OUTPATIENT PHARMACY;**625,630**;DEC 1997;Build 26
+2 ;
+3 ;
ASK ; MANUAL BATCH EXPORT
+1 ;RETRIEVE FILTERS FROM USER
+2 DO FULL^VALM1
SET VALMBCK="R"
+3 NEW %DT,DIR,DIRUT,X,DIC,DTOUT,DUOUT,BEGINDT,ENDDT,PSOERROR
+4 NEW RECTYPE,STATE,QUIT,ARRAY,TAG,FILTER
+5 ;
+6 ; - Selection of STATE
+7 WRITE !
SET DIC("A")="STATE: "
SET DIC("S")="I $D(^PS(58.41,+Y,0))"
SET DIC="^DIC(5,"
+8 SET DIC("B")=$$GET1^DIQ(5,+$ORDER(^PS(58.41,0)),.01)
+9 SET DIC(0)="AEQMZ"
DO ^DIC
IF X="^"!(Y<0)
QUIT
+10 SET STATE=+Y
BEGDT ;
+1 ; - Ask for Start DATE
+2 ; Note: The legislation allowing VA to report was published on 02/11/2013
+3 NEW XDT
SET XDT=$$FMADD^XLFDT(DT,-1)
+4 SET %DT(0)=3130211
SET %DT="AEP"
SET %DT("A")="Export Rx's Starting with RELEASE DATE (2/11/13 to "_$$FMTE^XLFDT(XDT,2)_"): "
+5 WRITE !
DO ^%DT
+6 IF X=""
WRITE !!?5,"Starting RELEASE DATE is required or enter '^' to exit.",!
GOTO BEGDT
+7 IF Y<0!($DATA(DTOUT))
QUIT
+8 IF (Y=DT)!(Y>DT)
WRITE !!?5,"Only past dates are allowed."
DO PAUSE^PSOSPMU1
GOTO BEGDT
+9 SET BEGINDT=Y
+10 ;
+11 WRITE !!?5,"Prescriptions released today will be included in the next scheduled batch."
+12 ;
ENDDT ;
+1 ; - Ask for End DATE
+2 KILL %DT
SET %DT(0)=BEGINDT\1
SET %DT="AEP"
SET %DT("B")="TODAY-1"
SET %DT("A")="Export Rx's Ending with RELEASE DATE ("_$$FMTE^XLFDT(BEGINDT,2)_" to "_$$FMTE^XLFDT(XDT,2)_"): "
+3 WRITE !
DO ^%DT
IF Y<0!($DATA(DTOUT))
QUIT
+4 IF (Y=DT)!(Y>DT)
WRITE !!?5,"The latest end date permitted is TODAY-1 (yesterday)."
DO PAUSE^PSOSPMU1
GOTO ENDDT
+5 SET ENDDT=Y
+6 ;
+7 SET QUIT=0
SET FILTER="NC"
+8 Begin DoDot:1
+9 KILL DIR
SET DIR("A")="Filter Selection"
+10 SET DIR(0)="S^PA:Patient;PR:Prescriber;DR:Drug;DV:Division;RX:Prescription;NC:No Criteria"
+11 SET DIR("L",1)="Select prescriptions by one of the following criteria:"
+12 SET DIR("L",2)=" "
+13 SET DIR("L",3)=" PA Patient"
+14 SET DIR("L",4)=" PR Prescriber"
+15 SET DIR("L",5)=" DR Drug"
+16 SET DIR("L",6)=" DV Division"
+17 SET DIR("L",7)=" RX Prescription"
+18 SET DIR("L")=" NC No criteria (unfiltered). All Rx's within the date range selected."
+19 DO ^DIR
IF $DATA(DUOUT)!($DATA(DIRUT))
KILL DIRUT,DUOUT,DIR
SET QUIT=1
QUIT
+20 SET FILTER=Y
End DoDot:1
if QUIT
QUIT
+21 ;
+22 KILL ARRAY
+23 SET TAG=$SELECT(FILTER="PA":"PATSEL",FILTER="PR":"PRESCSEL",FILTER="DR":"DRGSEL",FILTER="DV":"DIVSEL",FILTER="RX":"RXSEL",1:"NOCRITERIA")
+24 DO @TAG
+25 IF TAG'="NOCRITERIA"
IF '$ORDER(ARRAY(0))
QUIT
+26 DO RTSEL
+27 if QUIT
QUIT
+28 ; create and export the batch passing ARRAY which will be the iens of patients, prescribers, drugs, divisions, or prescriptions.
+29 ; If no filter criteria was selected then the ARRAY variable would equal "NC"
+30 DO EXPORT^PSOSPML1(STATE,BEGINDT,ENDDT,"RL",RECTYPE,.ARRAY)
+31 QUIT
+32 ;
NOCRITERIA ;
+1 ; No criteria was selected. All RXs will be sent within the given date range.
+2 SET ARRAY="NC"
+3 QUIT
+4 ;
PATSEL ;
+1 ; - Selection of PATIENTS
+2 NEW DIC,X,I,Y
+3 NEW DIR,DTOUT,DUOUT,DIROUT
+4 SET DIC(0)="QEAM"
SET DIC("A")="Select PATIENT: "
+5 WRITE !!,"You may enter one or more PATIENTS in succession.",!
+6 FOR
DO PATLK
SET Y=PSOPTLK
if +Y<1
QUIT
SET ARRAY(+Y)=""
KILL PSOPTLK
SET DIC("A")="Another PATIENT: "
+7 IF $GET(PSOPTLK)="^"
SET QUIT=1
KILL ARRAY
+8 IF $ORDER(ARRAY(0))
SET ARRAY="PA"
+9 QUIT
+10 ;
PRESCSEL ;
+1 ; - Selection of PRESCRIBERS
+2 NEW DIC,X,I,Y,DTOUT,DUOUT,DIRUT,DIROUT
+3 SET DIC="^VA(200,"
SET DIC(0)="QEAM"
+4 SET DIC("W")="W "" "",$P(^(""PS""),""^"",9)"
+5 SET DIC("A")="Select PRESCRIBER: "
+6 SET DIC("S")="I $D(^(""PS"")),$P(^(""PS""),""^""),$S('$P(^(""PS""),""^"",4):1,1:$P(^(""PS""),""^"",4)'<DT)"
+7 WRITE !!,"You may enter one or more PRESCRIBERS in succession.",!
+8 FOR
DO ^DIC
Begin DoDot:1
+9 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DIROUT)
KILL ARRAY
SET QUIT=1
QUIT
+10 IF +Y<1&'$ORDER(ARRAY(0))
WRITE !!,"Please enter at least one PRESCRIBER or '^' to exit.",!
QUIT
+11 IF +Y<1
SET QUIT=1
QUIT
+12 SET ARRAY(+Y)=""
+13 SET DIC("A")="Another PRESCRIBER: "
End DoDot:1
if QUIT
QUIT
+14 IF $ORDER(ARRAY(0))
SET ARRAY="PR"
+15 QUIT
+16 ;
DIVSEL ; - Division selection (one, multiple or ALL)
+1 NEW DIC,DTOUT,DUOUT,DIROUT,Y,X,XX
+2 WRITE !!,"You may enter one or more DIVISIONS in succession.",!
+3 IF '$GET(DT)
NEW DT
SET DT=$$NOW^XLFDT()
+4 SET DIC("S")="I $S('$D(^PS(59,+Y,""I"")):1,'^(""I""):1,DT'>^(""I""):1,1:0)"
+5 SET DIC="^PS(59,"
SET DIC(0)="QEZAM"
SET DIC("A")="Select DIVISION: "
+6 FOR
DO ^DIC
Begin DoDot:1
+7 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DIROUT)
KILL ARRAY
SET QUIT=1
QUIT
+8 IF +Y<1&'$ORDER(ARRAY(0))
WRITE !!,"Please enter at least one DIVISION or '^' to exit.",!
QUIT
+9 IF +Y<1
SET QUIT=1
QUIT
+10 SET ARRAY(+Y)=""
+11 SET DIC("A")="Another DIVISION: "
End DoDot:1
if QUIT
QUIT
+12 IF $ORDER(ARRAY(0))
SET ARRAY="DV"
+13 QUIT
+14 ;
DRGSEL ;
+1 ; Prompt for drug
+2 NEW DIC,Y,DTOUT,DUOUT,DIRUT,DIROUT
+3 SET DIC(0)="AEMQ"
SET DIC=50
+4 SET DIC("S")="I $$CSDRUG^PSOSPML7(Y)"
+5 SET DIC("A")="Select DRUG GENERIC NAME: "
+6 WRITE !!,"You may enter one or more DRUGS in succession.",!
+7 FOR
DO ^DIC
Begin DoDot:1
+8 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DIROUT)
KILL ARRAY
SET QUIT=1
QUIT
+9 IF +Y<1&'$ORDER(ARRAY(0))
WRITE !!,"Please enter at least one DRUG or '^' to exit.",!
QUIT
+10 IF +Y<1
SET QUIT=1
QUIT
+11 SET ARRAY(+Y)=""
+12 SET DIC("A")="Another DRUG: "
End DoDot:1
if QUIT
QUIT
+13 IF $ORDER(ARRAY(0))
SET ARRAY="DR"
+14 QUIT
+15 ;
RXSEL ;
+1 ; - Selection of prescriptions - Prescription prompt
+2 NEW DIR,X,Y,FILLNUM,SCREEN,DTOUT,DUOUT,DIROUT
+3 WRITE !!,"You may enter one or more PRESCRIPTIONS in succession.",!
+4 FOR
DO RXSEL1
if QUIT
QUIT
+5 IF $ORDER(ARRAY(0))
SET ARRAY="RX"
+6 QUIT
RXSEL1 ;
+1 SET DIR("A")=$SELECT('$ORDER(ARRAY(0)):"Select PRESCRIPTION: ",1:"Another PRESCRIPTION: ")
+2 SET DIR(0)="FAO^1:30"
SET (DIR("?"),DIR("??"))="^D HLP^PSOSPML7"
+3 DO ^DIR
+4 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
KILL ARRAY
SET QUIT=1
QUIT
+5 IF X=""&'$ORDER(ARRAY(0))
WRITE !!,"Please enter at least one PRESCRIPTION or '^' to exit.",!
QUIT
+6 IF X=""
SET QUIT=1
QUIT
+7 SET X=$$UP^XLFSTR(X)
SET QUIT=0
+8 IF $EXTRACT(X,1,2)'="E."
SET RXIEN=+$$RXLKP(X)
IF RXIEN<0
QUIT
+9 IF $EXTRACT(X,1,2)="E."
Begin DoDot:1
+10 IF $LENGTH(X)'=9
WRITE !?5,"The ECME# must be 7 digits long!",$CHAR(7)
SET QUIT=1
QUIT
+11 SET RXIEN=+$$RXNUM^PSOBPSU2($EXTRACT(X,3,9))
IF RXIEN<0
WRITE " ??"
SET QUIT=1
End DoDot:1
IF QUIT
SET QUIT=0
QUIT
+12 SET FILLNUM=$$RXFILL^PSOSPMU2(RXIEN)
IF FILLNUM="^"
SET QUIT=1
QUIT
+13 SET SCREEN=$$SCREEN^PSOSPMUT(RXIEN,FILLNUM)
+14 IF +SCREEN
Begin DoDot:1
+15 WRITE !!?1,$SELECT($PIECE(SCREEN,"^",3)="E":"ERROR",1:"WARNING"),": ",$PIECE(SCREEN,"^",2),$CHAR(7)
DO PAUSE^PSOSPMU1
End DoDot:1
if $PIECE(SCREEN,"^",3)="E"
QUIT
+16 IF '$$RXRLDT^PSOBPSUT(RXIEN,FILLNUM)
Begin DoDot:1
+17 WRITE !!?1,"Cannot select. Prescription not RELEASED. "
DO PAUSE^PSOSPMU1
End DoDot:1
QUIT
+18 IF '$DATA(^PS(58.42,"ARX",RXIEN,FILLNUM))
Begin DoDot:1
+19 WRITE !!?1,"Cannot select. Prescription not previously in a transmission batch. "
DO PAUSE^PSOSPMU1
End DoDot:1
QUIT
+20 SET ARRAY(RXIEN,FILLNUM)=""
+21 ;
+22 QUIT
+23 ;
FILTER(LIST,RXIEN,FILL) ; Filter Rx Fills based on User Entered Filter Criteria
+1 ; Input: FILTER - List of Filter(s) to be screened
+2 ;(LIST="PR" or "DR" or "PA" or "NC" or "RX", LIST(PROV IEN) or (LIST(PAT IEN) or LIST(RXIEN,FILL)
+3 ; (r) RX - Rx IEN (#52)
+4 ; (r) RFL - Refill #
+5 ;
+6 ; Output: 1 - Filter (Skip) | 0 - Don't Filter (Include)
+7 NEW RXRES
+8 SET RXRES=0
+9 IF LIST="NC"
QUIT RXRES
+10 IF LIST="RX"
IF '$DATA(LIST(RXIEN,FILL))
SET RXRES=1
QUIT RXRES
+11 ;provider/prescriber filter
IF LIST="PR"
Begin DoDot:1
+12 IF '$DATA(LIST($$RXPRV(RXIEN,FILL)))
SET RXRES=1
QUIT
+13 ; fill not in a previously transmitted batch
IF '$DATA(^PS(58.42,"ARX",RXIEN,FILL))
SET RXRES=1
QUIT
End DoDot:1
QUIT RXRES
+14 IF LIST="DR"
Begin DoDot:1
+15 IF '$DATA(LIST($$GET1^DIQ(52,RXIEN,6,"I")))
SET RXRES=1
QUIT
+16 ; fill not in a previously transmitted batch
IF '$DATA(^PS(58.42,"ARX",RXIEN,FILL))
SET RXRES=1
QUIT
End DoDot:1
QUIT RXRES
+17 IF LIST="PA"
Begin DoDot:1
+18 IF '$DATA(LIST($$GET1^DIQ(52,RXIEN,2,"I")))
SET RXRES=1
QUIT
+19 ; fill not in a previously transmitted batch
IF '$DATA(^PS(58.42,"ARX",RXIEN,FILL))
SET RXRES=1
QUIT
End DoDot:1
QUIT RXRES
+20 IF LIST="DV"
Begin DoDot:1
+21 IF '$DATA(LIST($$RXSITE^PSOBPSUT(RXIEN,FILL)))
SET RXRES=1
QUIT
+22 ; fill not in a previously transmitted batch
IF '$DATA(^PS(58.42,"ARX",RXIEN,FILL))
SET RXRES=1
QUIT
End DoDot:1
QUIT RXRES
+23 IF LIST="ARX"
IF $DATA(^PS(58.42,"ARX",RXIEN,FILL))
IF $$CHKST^PSOSPML8(RXIEN,FILL,$GET(LIST("STATE")))
QUIT 1
+24 QUIT RXRES
+25 ;
RXPRV(RXIEN,FILL) ; Returns the Rx Fill Provider IEN
+1 ; Input: (r) RXIEN - Rx IEN (#52)
+2 ; (o) FILL - Refill # (Default: most recent - except Partial)
+3 ; Note: "P1", "P2"... represent partial fills
+4 ; Output: RXPRV - Rx Fill Provider IEN
+5 NEW RXPRV
+6 IF '$GET(RXIEN)
QUIT ""
+7 IF '$DATA(FILL)
SET FILL=$$LSTRFL(RXIEN)
+8 IF FILL
SET RXPRV=$$GET1^DIQ(52.1,FILL_","_RXIEN,15,"I")
+9 IF FILL["P"
SET RXPRV=$$GET1^DIQ(52.2,+$EXTRACT(FILL,2,9)_","_RXIEN,6,"I")
+10 IF '$GET(RXPRV)
SET RXPRV=$$GET1^DIQ(52,RXIEN,4,"I")
+11 QUIT RXPRV
+12 ;
LSTRFL(RX) ; - Returns the latest fill for the Rx
+1 ; Input: (r) RX - Rx IEN (#52)
+2 ;Output: LSTRFL - Most recent refill #
+3 NEW I,LSTRFL
+4 SET (I,LSTRFL)=0
FOR
SET I=$ORDER(^PSRX(RX,1,I))
if 'I
QUIT
SET LSTRFL=I
+5 QUIT LSTRFL
+6 ;
+7 ;
HLP ; Help Text for the VIEW PRESCRIPTION prompt
+1 WRITE !," A prescription number or ECME number may be entered. To look-up a"
+2 WRITE !," prescription by the ECME number, please enter ""E."" followed by the ECME"
+3 WRITE !," number with or without any leading zeros."
+4 DO LKP("?")
+5 QUIT
+6 ;
LKP(INPUT) ; - Performs Lookup on the PRESCRIPTION file
+1 NEW DIC,X,Y
+2 SET DIC="^PSRX("
SET DIC(0)="QE"
SET D="B"
SET X=INPUT
+3 SET DIC("S")="I $$CSRX^PSOSPML7(Y)"
+4 DO IX^DIC
+5 QUIT Y
+6 ;
RXLKP(RXNUM) ; - Peforms Lookup on the PRESCRIPTION file
+1 NEW DIC,X,Y,D
+2 SET DIC="^PSRX("
SET DIC(0)="QE"
SET D="B"
SET X=RXNUM
+3 DO IX^DIC
+4 QUIT Y
+5 ;
CSRX(RXIEN) ; Controlled Substance Rx?
+1 ; Input: RXIEN - PRESCRIPTION file (#52) pointer
+2 ;Output: $$CS - 1:YES / 0:NO
+3 NEW DRGIEN,DEA
+4 SET DRGIEN=$PIECE($GET(^PSRX(RXIEN,0)),U,6)
IF 'DRGIEN
QUIT 0
+5 ; retrieve DEA special handling code(s)
SET DEA=$PIECE($GET(^PSDRUG(DRGIEN,0)),U,3)
+6 IF (DEA'["0")
IF (DEA'["M")
IF (DEA["2")!(DEA["3")!(DEA["4")!(DEA["5")
QUIT 1
+7 QUIT 0
+8 ;
RTSEL ;
+1 ; - Selection of record type
+2 SET RECTYPE="N"
SET QUIT=0
+3 Begin DoDot:1
+4 KILL DIR
SET DIR("A")="Record Type"
+5 SET DIR("L",1)="Enter the type of record to be sent for released prescription fills:"
+6 SET DIR("L",2)=" "
+7 SET DIR(0)="S^N:NEW;R:REVISE"
+8 SET DIR("L",3)=" N NEW"
+9 SET DIR("L")=" R REVISE"
+10 SET DIR("?",1)="NEW is used for records that were rejected and NOT sent to the State database."
+11 SET DIR("?")="REVISE is used only for records that were rejected but were still sent to the State database."
+12 SET DIR("B")="NEW"
DO ^DIR
IF $DATA(DUOUT)!($DATA(DIRUT))
KILL DIRUT,DUOUT,DIR
SET QUIT=1
QUIT
+13 SET RECTYPE=Y
End DoDot:1
if QUIT
QUIT
+14 QUIT
CSDRUG(IEN) ;Controlled Substance drug?
+1 ; Input: DRGIEN - DRUG file (#50) pointer
+2 ;Output: $$CS - 1:YES / 0:NO
+3 NEW DEA
+4 if 'IEN
QUIT 0
+5 SET DEA=$PIECE($GET(^PSDRUG(IEN,0)),U,3)
+6 IF (DEA'["0")
IF (DEA'["M")
IF (DEA["2")!(DEA["3")!(DEA["4")!(DEA["5")
QUIT 1
+7 QUIT 0
+8 ;
PATLK ;Entry point - Prompts for Patient, Prescription Number or Barcode
+1 ;
+2 ; Input - DIC(0) & DIC("A") [Optional]
+3 ; Used by DIR if defined by the calling routine.
+4 ;
+5 ; Output - PSOPTLK [Processed user response]
+6 ;
+7 KILL PSOPTLK,PAGE
+8 SET DIR(0)="FOU"_$SELECT($DATA(DIC("A")):"A",1:"")_"^^K:$$PATVAL^PSOPATLK() X"
+9 SET DIR("A")=$SELECT($DATA(DIC("A")):DIC("A"),1:"Select PATIENT NAME")
+10 SET (DIR("?"),DIR("??"))="^D PATHLP^PSOPATLK"
+11 DO ^DIR
+12 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
SET Y="^"
+13 IF Y=""&'$ORDER(ARRAY(0))
WRITE !!,"Please enter at least one PATIENT or '^' to exit.",!
GOTO PATLK
+14 MERGE PSOPTLK=Y
+15 QUIT
