PSOBBC ;IHS/DSD/JCM - BATCH BARCODE DRIVER ;Feb 03, 2022@11:08
;;7.0;OUTPATIENT PHARMACY;**11,22,27,34,46,130,146,185,242,264,300,337,313,473,504,570,653,441**;DEC 1997;Build 208
;
;External reference to ^IBE(350.1,"ANEW" supported by DBIA 592
;External references CHPUS^IBACUS and TRI^IBACUS supported by DBIA 2030
;External references LK^ORX2 and ULK^ORX2 supported by DBIA 867
;External references ^PS(55 supported by DBIA 2228
;External references U, UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789
;PSO*242 change default to from Q to S
;-------------------------------------------------------------------
START ;
N PSODFN,PSOBBCNO
D INIT I '$D(PSOPAR) D ^PSOLSET G:'$D(PSOPAR) EOJ
I $P($G(PSOPAR),"^",2),'$D(^XUSEC("PSORPH",DUZ)) S PSORX("VERIFY")=1 ;337
I $G(PSOSITE) S PSOBARID=$G(^PS(59,PSOSITE,"IB")) I '$D(^IBE(350.1,"ANEW",+PSOBARID,1,1)) D S PSORX("QFLG")=1 K PSOBARID G END
.W $C(7),!!,"WARNING: Pharmacy Copay not working,",!,?10,"Check IB SERVICE/SECTION in Pharmacy Site File.",!!!,"You will not be able to enter any new prescriptions until this is corrected!"
S PSOBBC("QFLG")=0,PSORX("BAR CODE")=1
D FROM I PSOBBC("QFLG") S PSORX("QFLG")=1 G END
D ASK I PSOBBC("QFLG") S PSORX("QFLG")=1 G END
D PROCESS
END D EOJ
Q
;--------------------------------------------------------------------
INIT ;
S PSOBBC("QFLG")=0,PSORX("BAR CODE")=1 K PPL
I '$G(PSOINST) D
.K DIC,DR,DIQ S DA=$P($$SITE^VASITE(),"^") I DA D
..K PSOINST S DIC=4,DIQ(0)="I",DR=99,DIQ="PSOINST" D EN^DIQ1
..S PSOINST=PSOINST(4,DA,99,"I") K DIC,DA,DIQ,PSOINST(4)
Q
FROM ;
S DIR(0)="S^1:REFILLS;2:RENEWS;"
S DIR("A")="Batch Barcode for",DIR("B")="REFILLS"
D DIR G:'Y FROMX
S PSOBBC1("FROM")=$S(Y=1:"REFILL",1:"NEW")
FROMX K X,Y,DIR
Q
;
ASK ;
K BINGCRT,BINGRTE,BBRX
W !,"Please answer the following for this session of prescriptions:",!
D EN^PSOREF2(.PSOBBC) I PSOBBC("DFLG") S PSOBBC("QFLG")=1 G ASKX
D SUSP G:PSOBBC("QFLG") ASKX
D INPT G:PSOBBC("QFLG") ASKX
D CNH G:PSOBBC("QFLG") ASKX
D:'$P($G(PSOPAR),"^",6) EARLY G:PSOBBC("QFLG") ASKX
D SET
D:PSOBBC1("FROM")="NEW" NOORE^PSONEW(.PSOBBC) S:$G(PSOBBC("NOO"))'="" PSOBBCNO=$G(PSOBBC("NOO")) S:$G(PSOBBC("DFLG")) PSOBBC("QFLG")=1
ASKX Q
;
SUSP ;
S DIR(0)="SAB^Q:QUEUED;S:SUSPENDED"
S DIR("A")="Will these refills be Queued or Suspended ? "
S DIR("B")="S" ;PSO*242
D DIR G:PSOBBC("QFLG") SUSPX
S (PSOBBC1("QS"),PSOBBC("QS"))=Y S:PSOBBC1("QS")="S" BINGCRT=0
SUSPX K X,Y,DIR
Q
;
INPT ;
N DIR,PSOINP
S DIR(0)="YA"
S DIR("A")="Allow refills for Inpatient ? "
S PSOINP=$$GET1^DIQ(59,PSOSITE,2030)
S DIR("B")=$S(PSOINP'="":PSOINP,1:"NO")
D DIR G:PSOBBC("QFLG") INPTX
S (PSOBBC1("INOK"),PSOBBC("INOK"))=Y
INPTX K X,Y,DIR
Q
CNH ;
N DIR,PSOCNH
S DIR(0)="YA"
S DIR("A")="Allow refills for CNH ? "
S PSOCNH=$$GET1^DIQ(59,PSOSITE,2035)
S DIR("B")=$S(PSOCNH'="":PSOCNH,1:"NO")
D DIR G:PSOBBC("QFLG") CNHX
S (PSOBBC1("CNHOK"),PSOBBC("CNHOK"))=Y
CNHX K X,Y,DIR
Q
;
EARLY ;
S DIR(0)="YA"
S DIR("A")="Allow early refills ? "
S DIR("B")="N"
D DIR G:PSOBBC("QFLG") EARLYX
S (PSOBBC1("EAOK"),PSOBBC("EAOK"))=Y
EARLYX K X,Y,DIR
Q
;
SET ;
S PSOBBC1("MAIL/WINDOW")=PSOBBC("MAIL/WINDOW") S:PSOBBC1("MAIL/WINDOW")="W" BINGRTE="W"
S PSOBBC1("FILL DATE")=PSOBBC("FILL DATE")
S:$G(PSOBBC("CLERK CODE")) PSOBBC1("CLERK CODE")=PSOBBC("CLERK CODE")
S:$G(PSOBBC("EXPIRATION DATE")) PSOBBC1("EXPIRATION DATE")=PSOBBC("EXPIRATION DATE")
Q
DIR ;
D ^DIR
S:$D(DIRUT) PSOBBC("QFLG")=1,PSORX("QFLG")=1
K DIRUT,DUOUT,DTOUT,DIROUT
Q
;
PROCESS ;
S PSOBBC("DFLG")=0 D NOW^%DTC S TM=$E(%,1,12),TM1=$P(TM,".",2)
S RXN=$O(^TMP("PSORXN",$J,0)) I RXN D
.S RXN1=^TMP("PSORXN",$J,RXN) D EN^PSOHLSN1(RXN,$P(RXN1,"^"),$P(RXN1,"^",2),"",$P(RXN1,"^",3))
.I $P(^PSRX(RXN,"STA"),"^")=5 D EN^PSOHLSN1(RXN,"SC","ZS","")
K RXN,RXN1,SIG,^TMP("PSORXN",$J)
D CLEAN^PSOVER1 K ^TMP("PSORXDC",$J)
D GETRXM D:PSOBBC("QFLG") ULK,ULP,ULRX G:PSOBBC("QFLG") PROCESSX
I $G(PSODFN)'=$P(^PSRX(PSOBBC("IRXN"),0),"^",2) D G:PSOBBC("DFLG") PROCESS
.I $G(PSODFN) D ULK,ULP
.D PT Q:PSOBBC("DFLG")
.D PROFILE^PSORX1
E D PTC G:PSOBBC("DFLG") PROCESS
D:'$G(PSOSD) ^PSOBUILD
S PSOBBC("DONE")=PSOBBC("IRXN")_","
D @PSOBBC1("FROM") S:$G(PPL)&$D(BINGRTE) BBRX(1)=$S($D(PSOBBC("DONE")):PSOBBC("DONE"),1:BBRX) D:$D(BINGCRT)&($D(BINGRTE)&($D(DISGROUP))) ^PSOBING1 K BBRX D ULRX G PROCESS
PROCESSX I $G(PPL) D SETX,TRI,Q^PSORXL K PPL,RXFL
Q
GETRXM ;
N PRVCHK
K DIR,PSOBBC("IRXN"),PSOREFXM
S DIR(0)="FO^5:245^K:X'?3N1""-""1.N X"
S DIR("A")="WAND BARCODE"
S DIR("?",1)="Wand the barcoded number of the prescription to be processed."
S DIR("?",2)="The number should be of the form NNN-NNNNNN"
S DIR("?",3)="where the number before the dash is your station number."
S DIR("?")="Enter ""^"", or a RETURN to quit."
D DIR G:PSOBBC("QFLG") GETRXMX
I $P(X,"-")'=PSOINST W !?7,$C(7),$C(7),$C(7),"Not From this Institution" G GETRXM
S (PSOBBC("IRXN"),PSOBBC("OIRXN"),BBRX)=$P(X,"-",2)
I $G(^PSRX(PSOBBC("IRXN"),0))']"" W !,$C(7),"Rx data is not on file !",! G GETRXM
I $G(PSOBBC1("FROM"))="NEW" S PRVCHK=$$CHKRXPRV^PSOUTIL(PSOBBC("IRXN")) I 'PRVCHK W $C(7),!!,$P(PRVCHK,"^",2),! G GETRXM
I $$TITRX^PSOUTL(PSOBBC("IRXN"))="t" D G GETRXM
. W $C(7),!!,"Rx# "_$$GET1^DIQ(52,PSOBBC("IRXN"),.01)_" is marked as 'Titration Rx' and cannot be "_$S(PSOBBC1("FROM")="REFILL":"refilled.",1:"renewed."),!
S PSOXDFN=+$P($G(^PSRX(PSOBBC("IRXN"),0)),"^",2) I PSOXDFN S PSOLOUD=1 D:$P($G(^PS(55,PSOXDFN,0)),"^",6)'=2 EN^PSOHLUP(PSOXDFN) K PSOLOUD
K PSOXDFN I $P($G(^PSRX(PSOBBC("IRXN"),"STA")),"^")=13 W !,$C(7),"Rx has already been deleted." G GETRXM
I $G(PSOBBC("DONE"))[PSOBBC("IRXN")_"," W !,$C(7),"Rx has already been entered" G GETRXM
I $G(PSOBBC1("FROM"))="REFILL" S PSOREFXM=$G(PSOBBC("IRXN")) I PSOREFXM D PSOL^PSSLOCK(PSOREFXM) I '$G(PSOMSG) D K PSOMSG G GETRXM
.I $P($G(PSOMSG),"^",2)'="" W $C(7),!!?5,$P(PSOMSG,"^",2),! Q
.W $C(7),!!?5,"Another person is editing Rx "_$P($G(^PSRX(+$G(PSOBBC("IRXN")),0)),"^"),!
I '$D(PSODFNX(+$P(^PSRX(PSOBBC("IRXN"),0),"^",2))),$G(PSOBBC1("FROM"))="NEW" K PSONOERR D G:'$G(PSOPLCK)!($G(PSONOERR)) GETRXM
.S PSOPLCK=$$L^PSSLOCK(+$P(^PSRX(PSOBBC("IRXN"),0),"^",2),0) I '$G(PSOPLCK) D LOCK^PSOORCPY Q
.S X=+$P(^PSRX(PSOBBC("IRXN"),0),"^",2)_";DPT(" D LK^ORX2 I 'Y S PSONOERR=1 D UL^PSSLOCK(+$P(^PSRX(PSOBBC("IRXN"),0),"^",2)) Q
.S PSODFNX(+$P(^PSRX(PSOBBC("IRXN"),0),"^",2))=""
GETRXMX K X,Y,DIR,PSOOPT
Q
;
PT ;
S PSOBBC("DFLG")=0
W !,$C(7),"New Patient, please pause",!
I $G(PPL) D SETX,TRI,Q^PSORXL K PPL
K RXFL
S (DFN,PSODFN)=$P(^PSRX(PSOBBC("IRXN"),0),"^",2),PSORX("NAME")=$P(^DPT(PSODFN,0),"^")
D ICN^PSODPT(DFN)
;CHECK FOR BAD ADDRESS/SAB
S PSOLOUD=1 D:$P($G(^PS(55,PSODFN,0)),"^",6)'=2 EN^PSOHLUP(PSODFN) K PSOLOUD
D ^PSOBUILD
S PSOX=$G(^PS(55,PSODFN,"PS")) I PSOX]"" S PSORX("PATIENT STATUS")=$P($G(^PS(53,PSOX,0)),"^")
K PSOX
PTC S (DFN,PSODFN)=$P(^PSRX(PSOBBC("IRXN"),0),"^",2)
S PSOLOUD=1 D:$P($G(^PS(55,PSODFN,0)),"^",6)'=2 EN^PSOHLUP(PSODFN) K PSOLOUD
S PSOBBC("DFLG")=0 D GET^PSOPTPST
I $G(PSOPTPST(2,PSODFN,.351))]"" S PSOBBC("DFLG")=1 D DEAD^PSOPTPST G PTX
N PSOTPEXT I $G(PSOBBC1("FROM"))="NEW",$D(^PS(52.91,PSODFN,0)) I '$P(^PS(52.91,PSODFN,0),"^",3)!($P(^(0),"^",3)>DT) D PDIR^PSOTPCAN(PSODFN) I $G(PSOTPEXT) K PSOTPEXT S PSOBBC("DFLG")=1 G PTX
K PSOTPEXT
I $G(PSOPTPST(2,PSODFN,.1))]"" D:'PSOBBC("INOK") PID W !,$C(7),?10,"PATIENT IS AN INPATIENT ON WARD ",PSOPTPST(2,PSODFN,.1)," !!" I 'PSOBBC("INOK") S PSOBBC("DFLG")=1 G PTX
K PSORX("CNH")
I $G(PSOPTPST(2,PSODFN,148))="YES" D:'PSOBBC("CNHOK") PID W !,$C(7),?10,"PATIENT IS IN A CONTRACT NURSING HOME !!" S:PSOBBC("CNHOK") PSORX("CNH")=1 I 'PSOBBC("CNHOK") S PSOBBC("DFLG")=1 G PTX
D:PSOBBC1("FROM")="NEW" COPAY^PSOPTPST
PTX K PSOPTPST W:PSOBBC("DFLG") !!,$C(7),"Rx not filled" W:$G(PSOBBC("IRXN")) " RX IEN "_PSOBBC("IRXN") ;RTW NSR20160206
Q
;
REFILL ;
; Titration Rx refill request check from AudioFax/Internet
N PSORXIEN,PSOPARKED,PSOORIG
S PSORXIEN=+$G(PSOBBC("IRXN"))
S PSOORIG=0
S PSOPARKED=($G(^PSRX(PSORXIEN,"STA"))=0)&($G(^PSRX(PSORXIEN,"PARK")))
I PSOPARKED S PSOORIG=$$CHKPRKORIG^PSOPRKA(PSORXIEN) ;check if filling original or refill
;
; p441 PAPI - don't quit here if filling original parked titration
I PSORXIEN,$D(^PSRX(PSORXIEN,0)),$$TITRX^PSOUTL(PSORXIEN)="t",'PSOORIG D Q
. W !!,$C(7),"Rx# "_$$GET1^DIQ(52,PSORXIEN,.01)_" is marked as 'Titration Rx' and cannot be refilled.",!
. D PAUSE^VALM1
N PSOFROM S PSOFROM="REFILL",XFROM="BATCH"
D EN^PSOREF0(.PSOBBC)
Q
REFILLX ;
Q
;
NEW ;
; Titration Rx Renewal request check from AudioFax
N PSORXIEN,PSOACT
S PSORXIEN=+$G(PSOBBC("IRXN"))
I PSORXIEN,$D(^PSRX(PSORXIEN,0)),$$TITRX^PSOUTL(PSORXIEN)="t" D Q
. W !!,$C(7),"Rx# "_$$GET1^DIQ(52,PSORXIEN,.01)_" Drug: "_$$GET1^DIQ(52,PSORXIEN,6),!
. W !,"'Titration Rx' cannot be renewed."
. D PAUSE^VALM1
;
; Setting PSOACT to determine Listman actions available
I $$GET1^DIQ(52,PSORXIEN,310,"I") D
. S PSOACT=$S($D(^XUSEC("PSDRPH",DUZ)):"DEFX",$D(^XUSEC("PSORPH",DUZ)):"F",'$D(^XUSEC("PSORPH",DUZ))&($P($G(PSOPAR),"^",2)):"F",1:"")
E D
. S PSOACT=$S($D(^XUSEC("PSORPH",DUZ)):"DEFX",'$D(^XUSEC("PSORPH",DUZ))&($P($G(PSOPAR),"^",2)):"F",1:"")
;
N PSOFROM S (PSOFROM,XFROM)="BATCH"
S PSOBBC("OIRXN")=PSOBBC("IRXN")
S PSORNW("FILL DATE")=PSOBBC1("FILL DATE"),PSOOPT=3
S PSORX("DFLG")=0,PSOBBC("NOO")=$G(PSOBBCNO) D EN^PSORENW0(.PSOBBC)
S PSOBBC("MAIL/WINDOW")=PSOBBC1("MAIL/WINDOW")
S PSOBBC("EAOK")=$G(PSOBBC1("EAOK"))
S PSOBBC("QS")=PSOBBC1("QS")
S PSOBBC("INOK")=PSOBBC1("INOK")
S PSOBBC("CNHOK")=PSOBBC1("CNHOK")
S:$G(PSOBBC1("CLERK CODE")) PSOBBC("CLERK CODE")=PSOBBC1("CLERK CODE")
S:$G(PSOBBC1("EXPIRATION DATE")) PSOBBC("EXPIRATION DATE")=PSOBBC1("EXPIRATION DATE")
K PSORNW,PSOOPT
Q
;
EOJ ;
K PSOMSG,PSOREFXM,PSONOERR,PSOPLCK,PSOSD,PSOBBC,PSOBBC1,PSOBARID,Y,X,XFROM,PSOCOUU,PSOCOU,ACNT,ADFN,CLS,CMOP,CNT,FDR,HDR,PSCAN,JJ,POERR,PSOBCK,PSONEW3,PSORENW3,RXFL,PSOOPT
K PSORX,RFDT,RX1,RXS,SDA,PSONOOR,VALMBCK,VALMSG,SIG,SIGOK,STA,TM,TM1,VA,VADM,VAEL,VAPA
D CLEAN^PSOVER1 K ^TMP("PSORXDC",$J)
Q
TRI ;Check for Tricare Rx's
S X="IBACUS" X ^%ZOSF("TEST") I '$T Q
I '$$TRI^IBACUS Q
Q:'$G(PPL)
;PREV LINE, IN V 7 D ZOSF FIRST
N DA,NEWPPL,WWFLAG,PSOWRX,PSOWW,WWNEXT,WXRX,WPAT,WSITE,WDUZ,WFILL,WLOOP,WBILL,WPPLFLG,WWW
D DEV^PSOCPTRI
S NEWPPL=PPL S PPL=""
S (WWFLAG,WPPLFLG)=0 F PSOWW=1:1 S PSOWRX=$P(NEWPPL,",",PSOWW) D Q:$G(WWFLAG)
.S WWNEXT=$P(NEWPPL,",",(PSOWW+1)) I WWNEXT=""!(WWNEXT=",") S WWFLAG=1
.I '$G(DT) S DT=$$DT^XLFDT
.S WPAT=$P($G(^PSRX(+PSOWRX,0)),"^",2),WSITE=+$G(PSOSITE),WDUZ=+$G(DUZ)
.S WFILL=0 F WLOOP=0:0 S WLOOP=$O(^PSRX(+PSOWRX,1,WLOOP)) Q:'WLOOP S WFILL=WLOOP
.S WBILL=$$CHPUS^IBACUS(WPAT,DT,PSOWRX,WFILL,PSOLAP,WSITE,WDUZ)
.I '$G(WBILL) S WXRX(PSOWW,PSOWRX)="" Q
.S WPPLFLG=1
.S FLD(99)="99",FLD(99.1)="Awaiting CHAMPUS billing approval"
.N RSDT,ACT,PSUS,RXF,I,PSDA,NOW,IR,FDA,RFN S DA=PSOWRX D H^PSOCPTRH Q
I '$G(WPPLFLG) S PPL=NEWPPL Q
S WWW="" F S WWW=$O(WXRX(WWW)) Q:WWW="" D
.I $G(PPL)="" S PPL=$O(WXRX(WWW,0))_"," Q
.S PPL=PPL_$O(WXRX(WWW,0))_","
Q
ULK ;
Q:$G(PSOBBC1("FROM"))'="NEW"
I '$G(PSODFN) Q
S X=PSODFN_";DPT(" D ULK^ORX2 K PSODFNX(PSODFN) Q
ULP Q:$G(PSOBBC1("FROM"))'="NEW"
Q:'$G(PSODFN)
D UL^PSSLOCK(PSODFN)
Q
ULRX ;
Q:$G(PSOBBC1("FROM"))'="REFILL"
Q:'$G(PSOREFXM)
D PSOUL^PSSLOCK(PSOREFXM)
K PSOREFXM
Q
;
SETX ;
S:$G(PSOBBC1("FROM"))="REFILL" XFROM="BATCH"
S:$G(PSOBBC1("FROM"))="NEW" XFROM="BATCH"
Q
PID ;
I '$G(DFN) S DFN=+$G(PSODFN)
Q:'$G(DFN)
K VAPTYP D PID^VADPT
W !!,?9,$G(PSORX("NAME"))_" ",$G(VA("BID"))
K VA("BID"),VA("PID")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOBBC 11840 printed Oct 16, 2024@18:25:22 Page 2
PSOBBC ;IHS/DSD/JCM - BATCH BARCODE DRIVER ;Feb 03, 2022@11:08
+1 ;;7.0;OUTPATIENT PHARMACY;**11,22,27,34,46,130,146,185,242,264,300,337,313,473,504,570,653,441**;DEC 1997;Build 208
+2 ;
+3 ;External reference to ^IBE(350.1,"ANEW" supported by DBIA 592
+4 ;External references CHPUS^IBACUS and TRI^IBACUS supported by DBIA 2030
+5 ;External references LK^ORX2 and ULK^ORX2 supported by DBIA 867
+6 ;External references ^PS(55 supported by DBIA 2228
+7 ;External references U, UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789
+8 ;PSO*242 change default to from Q to S
+9 ;-------------------------------------------------------------------
START ;
+1 NEW PSODFN,PSOBBCNO
+2 DO INIT
IF '$DATA(PSOPAR)
DO ^PSOLSET
if '$DATA(PSOPAR)
GOTO EOJ
+3 ;337
IF $PIECE($GET(PSOPAR),"^",2)
IF '$DATA(^XUSEC("PSORPH",DUZ))
SET PSORX("VERIFY")=1
+4 IF $GET(PSOSITE)
SET PSOBARID=$GET(^PS(59,PSOSITE,"IB"))
IF '$DATA(^IBE(350.1,"ANEW",+PSOBARID,1,1))
Begin DoDot:1
+5 WRITE $CHAR(7),!!,"WARNING: Pharmacy Copay not working,",!,?10,"Check IB SERVICE/SECTION in Pharmacy Site File.",!!!,"You will not be able to enter any new prescriptions until this is corrected!"
End DoDot:1
SET PSORX("QFLG")=1
KILL PSOBARID
GOTO END
+6 SET PSOBBC("QFLG")=0
SET PSORX("BAR CODE")=1
+7 DO FROM
IF PSOBBC("QFLG")
SET PSORX("QFLG")=1
GOTO END
+8 DO ASK
IF PSOBBC("QFLG")
SET PSORX("QFLG")=1
GOTO END
+9 DO PROCESS
END DO EOJ
+1 QUIT
+2 ;--------------------------------------------------------------------
INIT ;
+1 SET PSOBBC("QFLG")=0
SET PSORX("BAR CODE")=1
KILL PPL
+2 IF '$GET(PSOINST)
Begin DoDot:1
+3 KILL DIC,DR,DIQ
SET DA=$PIECE($$SITE^VASITE(),"^")
IF DA
Begin DoDot:2
+4 KILL PSOINST
SET DIC=4
SET DIQ(0)="I"
SET DR=99
SET DIQ="PSOINST"
DO EN^DIQ1
+5 SET PSOINST=PSOINST(4,DA,99,"I")
KILL DIC,DA,DIQ,PSOINST(4)
End DoDot:2
End DoDot:1
+6 QUIT
FROM ;
+1 SET DIR(0)="S^1:REFILLS;2:RENEWS;"
+2 SET DIR("A")="Batch Barcode for"
SET DIR("B")="REFILLS"
+3 DO DIR
if 'Y
GOTO FROMX
+4 SET PSOBBC1("FROM")=$SELECT(Y=1:"REFILL",1:"NEW")
FROMX KILL X,Y,DIR
+1 QUIT
+2 ;
ASK ;
+1 KILL BINGCRT,BINGRTE,BBRX
+2 WRITE !,"Please answer the following for this session of prescriptions:",!
+3 DO EN^PSOREF2(.PSOBBC)
IF PSOBBC("DFLG")
SET PSOBBC("QFLG")=1
GOTO ASKX
+4 DO SUSP
if PSOBBC("QFLG")
GOTO ASKX
+5 DO INPT
if PSOBBC("QFLG")
GOTO ASKX
+6 DO CNH
if PSOBBC("QFLG")
GOTO ASKX
+7 if '$PIECE($GET(PSOPAR),"^",6)
DO EARLY
if PSOBBC("QFLG")
GOTO ASKX
+8 DO SET
+9 if PSOBBC1("FROM")="NEW"
DO NOORE^PSONEW(.PSOBBC)
if $GET(PSOBBC("NOO"))'=""
SET PSOBBCNO=$GET(PSOBBC("NOO"))
if $GET(PSOBBC("DFLG"))
SET PSOBBC("QFLG")=1
ASKX QUIT
+1 ;
SUSP ;
+1 SET DIR(0)="SAB^Q:QUEUED;S:SUSPENDED"
+2 SET DIR("A")="Will these refills be Queued or Suspended ? "
+3 ;PSO*242
SET DIR("B")="S"
+4 DO DIR
if PSOBBC("QFLG")
GOTO SUSPX
+5 SET (PSOBBC1("QS"),PSOBBC("QS"))=Y
if PSOBBC1("QS")="S"
SET BINGCRT=0
SUSPX KILL X,Y,DIR
+1 QUIT
+2 ;
INPT ;
+1 NEW DIR,PSOINP
+2 SET DIR(0)="YA"
+3 SET DIR("A")="Allow refills for Inpatient ? "
+4 SET PSOINP=$$GET1^DIQ(59,PSOSITE,2030)
+5 SET DIR("B")=$SELECT(PSOINP'="":PSOINP,1:"NO")
+6 DO DIR
if PSOBBC("QFLG")
GOTO INPTX
+7 SET (PSOBBC1("INOK"),PSOBBC("INOK"))=Y
INPTX KILL X,Y,DIR
+1 QUIT
CNH ;
+1 NEW DIR,PSOCNH
+2 SET DIR(0)="YA"
+3 SET DIR("A")="Allow refills for CNH ? "
+4 SET PSOCNH=$$GET1^DIQ(59,PSOSITE,2035)
+5 SET DIR("B")=$SELECT(PSOCNH'="":PSOCNH,1:"NO")
+6 DO DIR
if PSOBBC("QFLG")
GOTO CNHX
+7 SET (PSOBBC1("CNHOK"),PSOBBC("CNHOK"))=Y
CNHX KILL X,Y,DIR
+1 QUIT
+2 ;
EARLY ;
+1 SET DIR(0)="YA"
+2 SET DIR("A")="Allow early refills ? "
+3 SET DIR("B")="N"
+4 DO DIR
if PSOBBC("QFLG")
GOTO EARLYX
+5 SET (PSOBBC1("EAOK"),PSOBBC("EAOK"))=Y
EARLYX KILL X,Y,DIR
+1 QUIT
+2 ;
SET ;
+1 SET PSOBBC1("MAIL/WINDOW")=PSOBBC("MAIL/WINDOW")
if PSOBBC1("MAIL/WINDOW")="W"
SET BINGRTE="W"
+2 SET PSOBBC1("FILL DATE")=PSOBBC("FILL DATE")
+3 if $GET(PSOBBC("CLERK CODE"))
SET PSOBBC1("CLERK CODE")=PSOBBC("CLERK CODE")
+4 if $GET(PSOBBC("EXPIRATION DATE"))
SET PSOBBC1("EXPIRATION DATE")=PSOBBC("EXPIRATION DATE")
+5 QUIT
DIR ;
+1 DO ^DIR
+2 if $DATA(DIRUT)
SET PSOBBC("QFLG")=1
SET PSORX("QFLG")=1
+3 KILL DIRUT,DUOUT,DTOUT,DIROUT
+4 QUIT
+5 ;
PROCESS ;
+1 SET PSOBBC("DFLG")=0
DO NOW^%DTC
SET TM=$EXTRACT(%,1,12)
SET TM1=$PIECE(TM,".",2)
+2 SET RXN=$ORDER(^TMP("PSORXN",$JOB,0))
IF RXN
Begin DoDot:1
+3 SET RXN1=^TMP("PSORXN",$JOB,RXN)
DO EN^PSOHLSN1(RXN,$PIECE(RXN1,"^"),$PIECE(RXN1,"^",2),"",$PIECE(RXN1,"^",3))
+4 IF $PIECE(^PSRX(RXN,"STA"),"^")=5
DO EN^PSOHLSN1(RXN,"SC","ZS","")
End DoDot:1
+5 KILL RXN,RXN1,SIG,^TMP("PSORXN",$JOB)
+6 DO CLEAN^PSOVER1
KILL ^TMP("PSORXDC",$JOB)
+7 DO GETRXM
if PSOBBC("QFLG")
DO ULK
DO ULP
DO ULRX
if PSOBBC("QFLG")
GOTO PROCESSX
+8 IF $GET(PSODFN)'=$PIECE(^PSRX(PSOBBC("IRXN"),0),"^",2)
Begin DoDot:1
+9 IF $GET(PSODFN)
DO ULK
DO ULP
+10 DO PT
if PSOBBC("DFLG")
QUIT
+11 DO PROFILE^PSORX1
End DoDot:1
if PSOBBC("DFLG")
GOTO PROCESS
+12 IF '$TEST
DO PTC
if PSOBBC("DFLG")
GOTO PROCESS
+13 if '$GET(PSOSD)
DO ^PSOBUILD
+14 SET PSOBBC("DONE")=PSOBBC("IRXN")_","
+15 DO @PSOBBC1("FROM")
if $GET(PPL)&$DATA(BINGRTE)
SET BBRX(1)=$SELECT($DATA(PSOBBC("DONE")):PSOBBC("DONE"),1:BBRX)
if $DATA(BINGCRT)&($DATA(BINGRTE)&($DATA(DISGROUP)))
DO ^PSOBING1
KILL BBRX
DO ULRX
GOTO PROCESS
PROCESSX IF $GET(PPL)
DO SETX
DO TRI
DO Q^PSORXL
KILL PPL,RXFL
+1 QUIT
GETRXM ;
+1 NEW PRVCHK
+2 KILL DIR,PSOBBC("IRXN"),PSOREFXM
+3 SET DIR(0)="FO^5:245^K:X'?3N1""-""1.N X"
+4 SET DIR("A")="WAND BARCODE"
+5 SET DIR("?",1)="Wand the barcoded number of the prescription to be processed."
+6 SET DIR("?",2)="The number should be of the form NNN-NNNNNN"
+7 SET DIR("?",3)="where the number before the dash is your station number."
+8 SET DIR("?")="Enter ""^"", or a RETURN to quit."
+9 DO DIR
if PSOBBC("QFLG")
GOTO GETRXMX
+10 IF $PIECE(X,"-")'=PSOINST
WRITE !?7,$CHAR(7),$CHAR(7),$CHAR(7),"Not From this Institution"
GOTO GETRXM
+11 SET (PSOBBC("IRXN"),PSOBBC("OIRXN"),BBRX)=$PIECE(X,"-",2)
+12 IF $GET(^PSRX(PSOBBC("IRXN"),0))']""
WRITE !,$CHAR(7),"Rx data is not on file !",!
GOTO GETRXM
+13 IF $GET(PSOBBC1("FROM"))="NEW"
SET PRVCHK=$$CHKRXPRV^PSOUTIL(PSOBBC("IRXN"))
IF 'PRVCHK
WRITE $CHAR(7),!!,$PIECE(PRVCHK,"^",2),!
GOTO GETRXM
+14 IF $$TITRX^PSOUTL(PSOBBC("IRXN"))="t"
Begin DoDot:1
+15 WRITE $CHAR(7),!!,"Rx# "_$$GET1^DIQ(52,PSOBBC("IRXN"),.01)_" is marked as 'Titration Rx' and cannot be "_$SELECT(PSOBBC1("FROM")="REFILL":"refilled.",1:"renewed."),!
End DoDot:1
GOTO GETRXM
+16 SET PSOXDFN=+$PIECE($GET(^PSRX(PSOBBC("IRXN"),0)),"^",2)
IF PSOXDFN
SET PSOLOUD=1
if $PIECE($GET(^PS(55,PSOXDFN,0)),"^",6)'=2
DO EN^PSOHLUP(PSOXDFN)
KILL PSOLOUD
+17 KILL PSOXDFN
IF $PIECE($GET(^PSRX(PSOBBC("IRXN"),"STA")),"^")=13
WRITE !,$CHAR(7),"Rx has already been deleted."
GOTO GETRXM
+18 IF $GET(PSOBBC("DONE"))[PSOBBC("IRXN")_","
WRITE !,$CHAR(7),"Rx has already been entered"
GOTO GETRXM
+19 IF $GET(PSOBBC1("FROM"))="REFILL"
SET PSOREFXM=$GET(PSOBBC("IRXN"))
IF PSOREFXM
DO PSOL^PSSLOCK(PSOREFXM)
IF '$GET(PSOMSG)
Begin DoDot:1
+20 IF $PIECE($GET(PSOMSG),"^",2)'=""
WRITE $CHAR(7),!!?5,$PIECE(PSOMSG,"^",2),!
QUIT
+21 WRITE $CHAR(7),!!?5,"Another person is editing Rx "_$PIECE($GET(^PSRX(+$GET(PSOBBC("IRXN")),0)),"^"),!
End DoDot:1
KILL PSOMSG
GOTO GETRXM
+22 IF '$DATA(PSODFNX(+$PIECE(^PSRX(PSOBBC("IRXN"),0),"^",2)))
IF $GET(PSOBBC1("FROM"))="NEW"
KILL PSONOERR
Begin DoDot:1
+23 SET PSOPLCK=$$L^PSSLOCK(+$PIECE(^PSRX(PSOBBC("IRXN"),0),"^",2),0)
IF '$GET(PSOPLCK)
DO LOCK^PSOORCPY
QUIT
+24 SET X=+$PIECE(^PSRX(PSOBBC("IRXN"),0),"^",2)_";DPT("
DO LK^ORX2
IF 'Y
SET PSONOERR=1
DO UL^PSSLOCK(+$PIECE(^PSRX(PSOBBC("IRXN"),0),"^",2))
QUIT
+25 SET PSODFNX(+$PIECE(^PSRX(PSOBBC("IRXN"),0),"^",2))=""
End DoDot:1
if '$GET(PSOPLCK)!($GET(PSONOERR))
GOTO GETRXM
GETRXMX KILL X,Y,DIR,PSOOPT
+1 QUIT
+2 ;
PT ;
+1 SET PSOBBC("DFLG")=0
+2 WRITE !,$CHAR(7),"New Patient, please pause",!
+3 IF $GET(PPL)
DO SETX
DO TRI
DO Q^PSORXL
KILL PPL
+4 KILL RXFL
+5 SET (DFN,PSODFN)=$PIECE(^PSRX(PSOBBC("IRXN"),0),"^",2)
SET PSORX("NAME")=$PIECE(^DPT(PSODFN,0),"^")
+6 DO ICN^PSODPT(DFN)
+7 ;CHECK FOR BAD ADDRESS/SAB
+8 SET PSOLOUD=1
if $PIECE($GET(^PS(55,PSODFN,0)),"^",6)'=2
DO EN^PSOHLUP(PSODFN)
KILL PSOLOUD
+9 DO ^PSOBUILD
+10 SET PSOX=$GET(^PS(55,PSODFN,"PS"))
IF PSOX]""
SET PSORX("PATIENT STATUS")=$PIECE($GET(^PS(53,PSOX,0)),"^")
+11 KILL PSOX
PTC SET (DFN,PSODFN)=$PIECE(^PSRX(PSOBBC("IRXN"),0),"^",2)
+1 SET PSOLOUD=1
if $PIECE($GET(^PS(55,PSODFN,0)),"^",6)'=2
DO EN^PSOHLUP(PSODFN)
KILL PSOLOUD
+2 SET PSOBBC("DFLG")=0
DO GET^PSOPTPST
+3 IF $GET(PSOPTPST(2,PSODFN,.351))]""
SET PSOBBC("DFLG")=1
DO DEAD^PSOPTPST
GOTO PTX
+4 NEW PSOTPEXT
IF $GET(PSOBBC1("FROM"))="NEW"
IF $DATA(^PS(52.91,PSODFN,0))
IF '$PIECE(^PS(52.91,PSODFN,0),"^",3)!($PIECE(^(0),"^",3)>DT)
DO PDIR^PSOTPCAN(PSODFN)
IF $GET(PSOTPEXT)
KILL PSOTPEXT
SET PSOBBC("DFLG")=1
GOTO PTX
+5 KILL PSOTPEXT
+6 IF $GET(PSOPTPST(2,PSODFN,.1))]""
if 'PSOBBC("INOK")
DO PID
WRITE !,$CHAR(7),?10,"PATIENT IS AN INPATIENT ON WARD ",PSOPTPST(2,PSODFN,.1)," !!"
IF 'PSOBBC("INOK")
SET PSOBBC("DFLG")=1
GOTO PTX
+7 KILL PSORX("CNH")
+8 IF $GET(PSOPTPST(2,PSODFN,148))="YES"
if 'PSOBBC("CNHOK")
DO PID
WRITE !,$CHAR(7),?10,"PATIENT IS IN A CONTRACT NURSING HOME !!"
if PSOBBC("CNHOK")
SET PSORX("CNH")=1
IF 'PSOBBC("CNHOK")
SET PSOBBC("DFLG")=1
GOTO PTX
+9 if PSOBBC1("FROM")="NEW"
DO COPAY^PSOPTPST
PTX ;RTW NSR20160206
KILL PSOPTPST
if PSOBBC("DFLG")
WRITE !!,$CHAR(7),"Rx not filled"
if $GET(PSOBBC("IRXN"))
WRITE " RX IEN "_PSOBBC("IRXN")
+1 QUIT
+2 ;
REFILL ;
+1 ; Titration Rx refill request check from AudioFax/Internet
+2 NEW PSORXIEN,PSOPARKED,PSOORIG
+3 SET PSORXIEN=+$GET(PSOBBC("IRXN"))
+4 SET PSOORIG=0
+5 SET PSOPARKED=($GET(^PSRX(PSORXIEN,"STA"))=0)&($GET(^PSRX(PSORXIEN,"PARK")))
+6 ;check if filling original or refill
IF PSOPARKED
SET PSOORIG=$$CHKPRKORIG^PSOPRKA(PSORXIEN)
+7 ;
+8 ; p441 PAPI - don't quit here if filling original parked titration
+9 IF PSORXIEN
IF $DATA(^PSRX(PSORXIEN,0))
IF $$TITRX^PSOUTL(PSORXIEN)="t"
IF 'PSOORIG
Begin DoDot:1
+10 WRITE !!,$CHAR(7),"Rx# "_$$GET1^DIQ(52,PSORXIEN,.01)_" is marked as 'Titration Rx' and cannot be refilled.",!
+11 DO PAUSE^VALM1
End DoDot:1
QUIT
+12 NEW PSOFROM
SET PSOFROM="REFILL"
SET XFROM="BATCH"
+13 DO EN^PSOREF0(.PSOBBC)
+14 QUIT
REFILLX ;
+1 QUIT
+2 ;
NEW ;
+1 ; Titration Rx Renewal request check from AudioFax
+2 NEW PSORXIEN,PSOACT
+3 SET PSORXIEN=+$GET(PSOBBC("IRXN"))
+4 IF PSORXIEN
IF $DATA(^PSRX(PSORXIEN,0))
IF $$TITRX^PSOUTL(PSORXIEN)="t"
Begin DoDot:1
+5 WRITE !!,$CHAR(7),"Rx# "_$$GET1^DIQ(52,PSORXIEN,.01)_" Drug: "_$$GET1^DIQ(52,PSORXIEN,6),!
+6 WRITE !,"'Titration Rx' cannot be renewed."
+7 DO PAUSE^VALM1
End DoDot:1
QUIT
+8 ;
+9 ; Setting PSOACT to determine Listman actions available
+10 IF $$GET1^DIQ(52,PSORXIEN,310,"I")
Begin DoDot:1
+11 SET PSOACT=$SELECT($DATA(^XUSEC("PSDRPH",DUZ)):"DEFX",$DATA(^XUSEC("PSORPH",DUZ)):"F",'$DATA(^XUSEC("PSORPH",DUZ))&($PIECE($GET(PSOPAR),"^",2)):"F",1:"")
End DoDot:1
+12 IF '$TEST
Begin DoDot:1
+13 SET PSOACT=$SELECT($DATA(^XUSEC("PSORPH",DUZ)):"DEFX",'$DATA(^XUSEC("PSORPH",DUZ))&($PIECE($GET(PSOPAR),"^",2)):"F",1:"")
End DoDot:1
+14 ;
+15 NEW PSOFROM
SET (PSOFROM,XFROM)="BATCH"
+16 SET PSOBBC("OIRXN")=PSOBBC("IRXN")
+17 SET PSORNW("FILL DATE")=PSOBBC1("FILL DATE")
SET PSOOPT=3
+18 SET PSORX("DFLG")=0
SET PSOBBC("NOO")=$GET(PSOBBCNO)
DO EN^PSORENW0(.PSOBBC)
+19 SET PSOBBC("MAIL/WINDOW")=PSOBBC1("MAIL/WINDOW")
+20 SET PSOBBC("EAOK")=$GET(PSOBBC1("EAOK"))
+21 SET PSOBBC("QS")=PSOBBC1("QS")
+22 SET PSOBBC("INOK")=PSOBBC1("INOK")
+23 SET PSOBBC("CNHOK")=PSOBBC1("CNHOK")
+24 if $GET(PSOBBC1("CLERK CODE"))
SET PSOBBC("CLERK CODE")=PSOBBC1("CLERK CODE")
+25 if $GET(PSOBBC1("EXPIRATION DATE"))
SET PSOBBC("EXPIRATION DATE")=PSOBBC1("EXPIRATION DATE")
+26 KILL PSORNW,PSOOPT
+27 QUIT
+28 ;
EOJ ;
+1 KILL PSOMSG,PSOREFXM,PSONOERR,PSOPLCK,PSOSD,PSOBBC,PSOBBC1,PSOBARID,Y,X,XFROM,PSOCOUU,PSOCOU,ACNT,ADFN,CLS,CMOP,CNT,FDR,HDR,PSCAN,JJ,POERR,PSOBCK,PSONEW3,PSORENW3,RXFL,PSOOPT
+2 KILL PSORX,RFDT,RX1,RXS,SDA,PSONOOR,VALMBCK,VALMSG,SIG,SIGOK,STA,TM,TM1,VA,VADM,VAEL,VAPA
+3 DO CLEAN^PSOVER1
KILL ^TMP("PSORXDC",$JOB)
+4 QUIT
TRI ;Check for Tricare Rx's
+1 SET X="IBACUS"
XECUTE ^%ZOSF("TEST")
IF '$TEST
QUIT
+2 IF '$$TRI^IBACUS
QUIT
+3 if '$GET(PPL)
QUIT
+4 ;PREV LINE, IN V 7 D ZOSF FIRST
+5 NEW DA,NEWPPL,WWFLAG,PSOWRX,PSOWW,WWNEXT,WXRX,WPAT,WSITE,WDUZ,WFILL,WLOOP,WBILL,WPPLFLG,WWW
+6 DO DEV^PSOCPTRI
+7 SET NEWPPL=PPL
SET PPL=""
+8 SET (WWFLAG,WPPLFLG)=0
FOR PSOWW=1:1
SET PSOWRX=$PIECE(NEWPPL,",",PSOWW)
Begin DoDot:1
+9 SET WWNEXT=$PIECE(NEWPPL,",",(PSOWW+1))
IF WWNEXT=""!(WWNEXT=",")
SET WWFLAG=1
+10 IF '$GET(DT)
SET DT=$$DT^XLFDT
+11 SET WPAT=$PIECE($GET(^PSRX(+PSOWRX,0)),"^",2)
SET WSITE=+$GET(PSOSITE)
SET WDUZ=+$GET(DUZ)
+12 SET WFILL=0
FOR WLOOP=0:0
SET WLOOP=$ORDER(^PSRX(+PSOWRX,1,WLOOP))
if 'WLOOP
QUIT
SET WFILL=WLOOP
+13 SET WBILL=$$CHPUS^IBACUS(WPAT,DT,PSOWRX,WFILL,PSOLAP,WSITE,WDUZ)
+14 IF '$GET(WBILL)
SET WXRX(PSOWW,PSOWRX)=""
QUIT
+15 SET WPPLFLG=1
+16 SET FLD(99)="99"
SET FLD(99.1)="Awaiting CHAMPUS billing approval"
+17 NEW RSDT,ACT,PSUS,RXF,I,PSDA,NOW,IR,FDA,RFN
SET DA=PSOWRX
DO H^PSOCPTRH
QUIT
End DoDot:1
if $GET(WWFLAG)
QUIT
+18 IF '$GET(WPPLFLG)
SET PPL=NEWPPL
QUIT
+19 SET WWW=""
FOR
SET WWW=$ORDER(WXRX(WWW))
if WWW=""
QUIT
Begin DoDot:1
+20 IF $GET(PPL)=""
SET PPL=$ORDER(WXRX(WWW,0))_","
QUIT
+21 SET PPL=PPL_$ORDER(WXRX(WWW,0))_","
End DoDot:1
+22 QUIT
ULK ;
+1 if $GET(PSOBBC1("FROM"))'="NEW"
QUIT
+2 IF '$GET(PSODFN)
QUIT
+3 SET X=PSODFN_";DPT("
DO ULK^ORX2
KILL PSODFNX(PSODFN)
QUIT
ULP if $GET(PSOBBC1("FROM"))'="NEW"
QUIT
+1 if '$GET(PSODFN)
QUIT
+2 DO UL^PSSLOCK(PSODFN)
+3 QUIT
ULRX ;
+1 if $GET(PSOBBC1("FROM"))'="REFILL"
QUIT
+2 if '$GET(PSOREFXM)
QUIT
+3 DO PSOUL^PSSLOCK(PSOREFXM)
+4 KILL PSOREFXM
+5 QUIT
+6 ;
SETX ;
+1 if $GET(PSOBBC1("FROM"))="REFILL"
SET XFROM="BATCH"
+2 if $GET(PSOBBC1("FROM"))="NEW"
SET XFROM="BATCH"
+3 QUIT
PID ;
+1 IF '$GET(DFN)
SET DFN=+$GET(PSODFN)
+2 if '$GET(DFN)
QUIT
+3 KILL VAPTYP
DO PID^VADPT
+4 WRITE !!,?9,$GET(PSORX("NAME"))_" ",$GET(VA("BID"))
+5 KILL VA("BID"),VA("PID")
+6 QUIT
