Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSOBBC

PSOBBC.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ;External reference to ^IBE(350.1,"ANEW" supported by DBIA 592
  1. ;External references CHPUS^IBACUS and TRI^IBACUS supported by DBIA 2030
  1. ;External references LK^ORX2 and ULK^ORX2 supported by DBIA 867
  1. ;External references ^PS(55 supported by DBIA 2228
  1. ;External references U, UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789
  1. ;PSO*242 change default to from Q to S
  1. ;-------------------------------------------------------------------
  1. START ;
  1. N PSODFN,PSOBBCNO
  1. D INIT I '$D(PSOPAR) D ^PSOLSET G:'$D(PSOPAR) EOJ
  1. I $P($G(PSOPAR),"^",2),'$D(^XUSEC("PSORPH",DUZ)) S PSORX("VERIFY")=1 ;337
  1. 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
  1. .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!"
  1. S PSOBBC("QFLG")=0,PSORX("BAR CODE")=1
  1. D FROM I PSOBBC("QFLG") S PSORX("QFLG")=1 G END
  1. D ASK I PSOBBC("QFLG") S PSORX("QFLG")=1 G END
  1. D PROCESS
  1. END D EOJ
  1. Q
  1. ;--------------------------------------------------------------------
  1. INIT ;
  1. S PSOBBC("QFLG")=0,PSORX("BAR CODE")=1 K PPL
  1. I '$G(PSOINST) D
  1. .K DIC,DR,DIQ S DA=$P($$SITE^VASITE(),"^") I DA D
  1. ..K PSOINST S DIC=4,DIQ(0)="I",DR=99,DIQ="PSOINST" D EN^DIQ1
  1. ..S PSOINST=PSOINST(4,DA,99,"I") K DIC,DA,DIQ,PSOINST(4)
  1. Q
  1. FROM ;
  1. S DIR(0)="S^1:REFILLS;2:RENEWS;"
  1. S DIR("A")="Batch Barcode for",DIR("B")="REFILLS"
  1. D DIR G:'Y FROMX
  1. S PSOBBC1("FROM")=$S(Y=1:"REFILL",1:"NEW")
  1. FROMX K X,Y,DIR
  1. Q
  1. ;
  1. ASK ;
  1. K BINGCRT,BINGRTE,BBRX
  1. W !,"Please answer the following for this session of prescriptions:",!
  1. D EN^PSOREF2(.PSOBBC) I PSOBBC("DFLG") S PSOBBC("QFLG")=1 G ASKX
  1. D SUSP G:PSOBBC("QFLG") ASKX
  1. D INPT G:PSOBBC("QFLG") ASKX
  1. D CNH G:PSOBBC("QFLG") ASKX
  1. D:'$P($G(PSOPAR),"^",6) EARLY G:PSOBBC("QFLG") ASKX
  1. D SET
  1. D:PSOBBC1("FROM")="NEW" NOORE^PSONEW(.PSOBBC) S:$G(PSOBBC("NOO"))'="" PSOBBCNO=$G(PSOBBC("NOO")) S:$G(PSOBBC("DFLG")) PSOBBC("QFLG")=1
  1. ASKX Q
  1. ;
  1. SUSP ;
  1. S DIR(0)="SAB^Q:QUEUED;S:SUSPENDED"
  1. S DIR("A")="Will these refills be Queued or Suspended ? "
  1. S DIR("B")="S" ;PSO*242
  1. D DIR G:PSOBBC("QFLG") SUSPX
  1. S (PSOBBC1("QS"),PSOBBC("QS"))=Y S:PSOBBC1("QS")="S" BINGCRT=0
  1. SUSPX K X,Y,DIR
  1. Q
  1. ;
  1. INPT ;
  1. N DIR,PSOINP
  1. S DIR(0)="YA"
  1. S DIR("A")="Allow refills for Inpatient ? "
  1. S PSOINP=$$GET1^DIQ(59,PSOSITE,2030)
  1. S DIR("B")=$S(PSOINP'="":PSOINP,1:"NO")
  1. D DIR G:PSOBBC("QFLG") INPTX
  1. S (PSOBBC1("INOK"),PSOBBC("INOK"))=Y
  1. INPTX K X,Y,DIR
  1. Q
  1. CNH ;
  1. N DIR,PSOCNH
  1. S DIR(0)="YA"
  1. S DIR("A")="Allow refills for CNH ? "
  1. S PSOCNH=$$GET1^DIQ(59,PSOSITE,2035)
  1. S DIR("B")=$S(PSOCNH'="":PSOCNH,1:"NO")
  1. D DIR G:PSOBBC("QFLG") CNHX
  1. S (PSOBBC1("CNHOK"),PSOBBC("CNHOK"))=Y
  1. CNHX K X,Y,DIR
  1. Q
  1. ;
  1. EARLY ;
  1. S DIR(0)="YA"
  1. S DIR("A")="Allow early refills ? "
  1. S DIR("B")="N"
  1. D DIR G:PSOBBC("QFLG") EARLYX
  1. S (PSOBBC1("EAOK"),PSOBBC("EAOK"))=Y
  1. EARLYX K X,Y,DIR
  1. Q
  1. ;
  1. SET ;
  1. S PSOBBC1("MAIL/WINDOW")=PSOBBC("MAIL/WINDOW") S:PSOBBC1("MAIL/WINDOW")="W" BINGRTE="W"
  1. S PSOBBC1("FILL DATE")=PSOBBC("FILL DATE")
  1. S:$G(PSOBBC("CLERK CODE")) PSOBBC1("CLERK CODE")=PSOBBC("CLERK CODE")
  1. S:$G(PSOBBC("EXPIRATION DATE")) PSOBBC1("EXPIRATION DATE")=PSOBBC("EXPIRATION DATE")
  1. Q
  1. DIR ;
  1. D ^DIR
  1. S:$D(DIRUT) PSOBBC("QFLG")=1,PSORX("QFLG")=1
  1. K DIRUT,DUOUT,DTOUT,DIROUT
  1. Q
  1. ;
  1. PROCESS ;
  1. S PSOBBC("DFLG")=0 D NOW^%DTC S TM=$E(%,1,12),TM1=$P(TM,".",2)
  1. S RXN=$O(^TMP("PSORXN",$J,0)) I RXN D
  1. .S RXN1=^TMP("PSORXN",$J,RXN) D EN^PSOHLSN1(RXN,$P(RXN1,"^"),$P(RXN1,"^",2),"",$P(RXN1,"^",3))
  1. .I $P(^PSRX(RXN,"STA"),"^")=5 D EN^PSOHLSN1(RXN,"SC","ZS","")
  1. K RXN,RXN1,SIG,^TMP("PSORXN",$J)
  1. D CLEAN^PSOVER1 K ^TMP("PSORXDC",$J)
  1. D GETRXM D:PSOBBC("QFLG") ULK,ULP,ULRX G:PSOBBC("QFLG") PROCESSX
  1. I $G(PSODFN)'=$P(^PSRX(PSOBBC("IRXN"),0),"^",2) D G:PSOBBC("DFLG") PROCESS
  1. .I $G(PSODFN) D ULK,ULP
  1. .D PT Q:PSOBBC("DFLG")
  1. .D PROFILE^PSORX1
  1. E D PTC G:PSOBBC("DFLG") PROCESS
  1. D:'$G(PSOSD) ^PSOBUILD
  1. S PSOBBC("DONE")=PSOBBC("IRXN")_","
  1. 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
  1. PROCESSX I $G(PPL) D SETX,TRI,Q^PSORXL K PPL,RXFL
  1. Q
  1. GETRXM ;
  1. N PRVCHK
  1. K DIR,PSOBBC("IRXN"),PSOREFXM
  1. S DIR(0)="FO^5:245^K:X'?3N1""-""1.N X"
  1. S DIR("A")="WAND BARCODE"
  1. S DIR("?",1)="Wand the barcoded number of the prescription to be processed."
  1. S DIR("?",2)="The number should be of the form NNN-NNNNNN"
  1. S DIR("?",3)="where the number before the dash is your station number."
  1. S DIR("?")="Enter ""^"", or a RETURN to quit."
  1. D DIR G:PSOBBC("QFLG") GETRXMX
  1. I $P(X,"-")'=PSOINST W !?7,$C(7),$C(7),$C(7),"Not From this Institution" G GETRXM
  1. S (PSOBBC("IRXN"),PSOBBC("OIRXN"),BBRX)=$P(X,"-",2)
  1. I $G(^PSRX(PSOBBC("IRXN"),0))']"" W !,$C(7),"Rx data is not on file !",! G GETRXM
  1. I $G(PSOBBC1("FROM"))="NEW" S PRVCHK=$$CHKRXPRV^PSOUTIL(PSOBBC("IRXN")) I 'PRVCHK W $C(7),!!,$P(PRVCHK,"^",2),! G GETRXM
  1. I $$TITRX^PSOUTL(PSOBBC("IRXN"))="t" D G GETRXM
  1. . 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."),!
  1. 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
  1. K PSOXDFN I $P($G(^PSRX(PSOBBC("IRXN"),"STA")),"^")=13 W !,$C(7),"Rx has already been deleted." G GETRXM
  1. I $G(PSOBBC("DONE"))[PSOBBC("IRXN")_"," W !,$C(7),"Rx has already been entered" G GETRXM
  1. I $G(PSOBBC1("FROM"))="REFILL" S PSOREFXM=$G(PSOBBC("IRXN")) I PSOREFXM D PSOL^PSSLOCK(PSOREFXM) I '$G(PSOMSG) D K PSOMSG G GETRXM
  1. .I $P($G(PSOMSG),"^",2)'="" W $C(7),!!?5,$P(PSOMSG,"^",2),! Q
  1. .W $C(7),!!?5,"Another person is editing Rx "_$P($G(^PSRX(+$G(PSOBBC("IRXN")),0)),"^"),!
  1. I '$D(PSODFNX(+$P(^PSRX(PSOBBC("IRXN"),0),"^",2))),$G(PSOBBC1("FROM"))="NEW" K PSONOERR D G:'$G(PSOPLCK)!($G(PSONOERR)) GETRXM
  1. .S PSOPLCK=$$L^PSSLOCK(+$P(^PSRX(PSOBBC("IRXN"),0),"^",2),0) I '$G(PSOPLCK) D LOCK^PSOORCPY Q
  1. .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
  1. .S PSODFNX(+$P(^PSRX(PSOBBC("IRXN"),0),"^",2))=""
  1. GETRXMX K X,Y,DIR,PSOOPT
  1. Q
  1. ;
  1. PT ;
  1. S PSOBBC("DFLG")=0
  1. W !,$C(7),"New Patient, please pause",!
  1. I $G(PPL) D SETX,TRI,Q^PSORXL K PPL
  1. K RXFL
  1. S (DFN,PSODFN)=$P(^PSRX(PSOBBC("IRXN"),0),"^",2),PSORX("NAME")=$P(^DPT(PSODFN,0),"^")
  1. D ICN^PSODPT(DFN)
  1. ;CHECK FOR BAD ADDRESS/SAB
  1. S PSOLOUD=1 D:$P($G(^PS(55,PSODFN,0)),"^",6)'=2 EN^PSOHLUP(PSODFN) K PSOLOUD
  1. D ^PSOBUILD
  1. S PSOX=$G(^PS(55,PSODFN,"PS")) I PSOX]"" S PSORX("PATIENT STATUS")=$P($G(^PS(53,PSOX,0)),"^")
  1. K PSOX
  1. PTC S (DFN,PSODFN)=$P(^PSRX(PSOBBC("IRXN"),0),"^",2)
  1. S PSOLOUD=1 D:$P($G(^PS(55,PSODFN,0)),"^",6)'=2 EN^PSOHLUP(PSODFN) K PSOLOUD
  1. S PSOBBC("DFLG")=0 D GET^PSOPTPST
  1. I $G(PSOPTPST(2,PSODFN,.351))]"" S PSOBBC("DFLG")=1 D DEAD^PSOPTPST G PTX
  1. 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
  1. K PSOTPEXT
  1. 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
  1. K PSORX("CNH")
  1. 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
  1. D:PSOBBC1("FROM")="NEW" COPAY^PSOPTPST
  1. PTX K PSOPTPST W:PSOBBC("DFLG") !!,$C(7),"Rx not filled" W:$G(PSOBBC("IRXN")) " RX IEN "_PSOBBC("IRXN") ;RTW NSR20160206
  1. Q
  1. ;
  1. REFILL ;
  1. ; Titration Rx refill request check from AudioFax/Internet
  1. N PSORXIEN,PSOPARKED,PSOORIG
  1. S PSORXIEN=+$G(PSOBBC("IRXN"))
  1. S PSOORIG=0
  1. S PSOPARKED=($G(^PSRX(PSORXIEN,"STA"))=0)&($G(^PSRX(PSORXIEN,"PARK")))
  1. I PSOPARKED S PSOORIG=$$CHKPRKORIG^PSOPRKA(PSORXIEN) ;check if filling original or refill
  1. ;
  1. ; p441 PAPI - don't quit here if filling original parked titration
  1. I PSORXIEN,$D(^PSRX(PSORXIEN,0)),$$TITRX^PSOUTL(PSORXIEN)="t",'PSOORIG D Q
  1. . W !!,$C(7),"Rx# "_$$GET1^DIQ(52,PSORXIEN,.01)_" is marked as 'Titration Rx' and cannot be refilled.",!
  1. . D PAUSE^VALM1
  1. N PSOFROM S PSOFROM="REFILL",XFROM="BATCH"
  1. D EN^PSOREF0(.PSOBBC)
  1. Q
  1. REFILLX ;
  1. Q
  1. ;
  1. NEW ;
  1. ; Titration Rx Renewal request check from AudioFax
  1. N PSORXIEN,PSOACT
  1. S PSORXIEN=+$G(PSOBBC("IRXN"))
  1. I PSORXIEN,$D(^PSRX(PSORXIEN,0)),$$TITRX^PSOUTL(PSORXIEN)="t" D Q
  1. . W !!,$C(7),"Rx# "_$$GET1^DIQ(52,PSORXIEN,.01)_" Drug: "_$$GET1^DIQ(52,PSORXIEN,6),!
  1. . W !,"'Titration Rx' cannot be renewed."
  1. . D PAUSE^VALM1
  1. ;
  1. ; Setting PSOACT to determine Listman actions available
  1. I $$GET1^DIQ(52,PSORXIEN,310,"I") D
  1. . S PSOACT=$S($D(^XUSEC("PSDRPH",DUZ)):"DEFX",$D(^XUSEC("PSORPH",DUZ)):"F",'$D(^XUSEC("PSORPH",DUZ))&($P($G(PSOPAR),"^",2)):"F",1:"")
  1. E D
  1. . S PSOACT=$S($D(^XUSEC("PSORPH",DUZ)):"DEFX",'$D(^XUSEC("PSORPH",DUZ))&($P($G(PSOPAR),"^",2)):"F",1:"")
  1. ;
  1. N PSOFROM S (PSOFROM,XFROM)="BATCH"
  1. S PSOBBC("OIRXN")=PSOBBC("IRXN")
  1. S PSORNW("FILL DATE")=PSOBBC1("FILL DATE"),PSOOPT=3
  1. S PSORX("DFLG")=0,PSOBBC("NOO")=$G(PSOBBCNO) D EN^PSORENW0(.PSOBBC)
  1. S PSOBBC("MAIL/WINDOW")=PSOBBC1("MAIL/WINDOW")
  1. S PSOBBC("EAOK")=$G(PSOBBC1("EAOK"))
  1. S PSOBBC("QS")=PSOBBC1("QS")
  1. S PSOBBC("INOK")=PSOBBC1("INOK")
  1. S PSOBBC("CNHOK")=PSOBBC1("CNHOK")
  1. S:$G(PSOBBC1("CLERK CODE")) PSOBBC("CLERK CODE")=PSOBBC1("CLERK CODE")
  1. S:$G(PSOBBC1("EXPIRATION DATE")) PSOBBC("EXPIRATION DATE")=PSOBBC1("EXPIRATION DATE")
  1. K PSORNW,PSOOPT
  1. Q
  1. ;
  1. EOJ ;
  1. 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
  1. K PSORX,RFDT,RX1,RXS,SDA,PSONOOR,VALMBCK,VALMSG,SIG,SIGOK,STA,TM,TM1,VA,VADM,VAEL,VAPA
  1. D CLEAN^PSOVER1 K ^TMP("PSORXDC",$J)
  1. Q
  1. TRI ;Check for Tricare Rx's
  1. S X="IBACUS" X ^%ZOSF("TEST") I '$T Q
  1. I '$$TRI^IBACUS Q
  1. Q:'$G(PPL)
  1. ;PREV LINE, IN V 7 D ZOSF FIRST
  1. N DA,NEWPPL,WWFLAG,PSOWRX,PSOWW,WWNEXT,WXRX,WPAT,WSITE,WDUZ,WFILL,WLOOP,WBILL,WPPLFLG,WWW
  1. D DEV^PSOCPTRI
  1. S NEWPPL=PPL S PPL=""
  1. S (WWFLAG,WPPLFLG)=0 F PSOWW=1:1 S PSOWRX=$P(NEWPPL,",",PSOWW) D Q:$G(WWFLAG)
  1. .S WWNEXT=$P(NEWPPL,",",(PSOWW+1)) I WWNEXT=""!(WWNEXT=",") S WWFLAG=1
  1. .I '$G(DT) S DT=$$DT^XLFDT
  1. .S WPAT=$P($G(^PSRX(+PSOWRX,0)),"^",2),WSITE=+$G(PSOSITE),WDUZ=+$G(DUZ)
  1. .S WFILL=0 F WLOOP=0:0 S WLOOP=$O(^PSRX(+PSOWRX,1,WLOOP)) Q:'WLOOP S WFILL=WLOOP
  1. .S WBILL=$$CHPUS^IBACUS(WPAT,DT,PSOWRX,WFILL,PSOLAP,WSITE,WDUZ)
  1. .I '$G(WBILL) S WXRX(PSOWW,PSOWRX)="" Q
  1. .S WPPLFLG=1
  1. .S FLD(99)="99",FLD(99.1)="Awaiting CHAMPUS billing approval"
  1. .N RSDT,ACT,PSUS,RXF,I,PSDA,NOW,IR,FDA,RFN S DA=PSOWRX D H^PSOCPTRH Q
  1. I '$G(WPPLFLG) S PPL=NEWPPL Q
  1. S WWW="" F S WWW=$O(WXRX(WWW)) Q:WWW="" D
  1. .I $G(PPL)="" S PPL=$O(WXRX(WWW,0))_"," Q
  1. .S PPL=PPL_$O(WXRX(WWW,0))_","
  1. Q
  1. ULK ;
  1. Q:$G(PSOBBC1("FROM"))'="NEW"
  1. I '$G(PSODFN) Q
  1. S X=PSODFN_";DPT(" D ULK^ORX2 K PSODFNX(PSODFN) Q
  1. ULP Q:$G(PSOBBC1("FROM"))'="NEW"
  1. Q:'$G(PSODFN)
  1. D UL^PSSLOCK(PSODFN)
  1. Q
  1. ULRX ;
  1. Q:$G(PSOBBC1("FROM"))'="REFILL"
  1. Q:'$G(PSOREFXM)
  1. D PSOUL^PSSLOCK(PSOREFXM)
  1. K PSOREFXM
  1. Q
  1. ;
  1. SETX ;
  1. S:$G(PSOBBC1("FROM"))="REFILL" XFROM="BATCH"
  1. S:$G(PSOBBC1("FROM"))="NEW" XFROM="BATCH"
  1. Q
  1. PID ;
  1. I '$G(DFN) S DFN=+$G(PSODFN)
  1. Q:'$G(DFN)
  1. K VAPTYP D PID^VADPT
  1. W !!,?9,$G(PSORX("NAME"))_" ",$G(VA("BID"))
  1. K VA("BID"),VA("PID")
  1. Q