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