- 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 Feb 19, 2025@00:01:33 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