BEXRX7 ;cmi/anch/maw - BEX Audiocare Refill Driver - Pharmacy Version 7 Only [ 06/15/2010 9:18 PM ] ; 04 Dec 2015 8:08 AM
;;1.0;BEX TELEPHONE REFILL SYSTEM;**1,2,4,5,6**;APR 20, 2015;Build 7
;For O/P V7 only
;
;
START ;
S PSOBEX=1
S (VEXRX,BEXRX)=1
K PSOBEXI,PSOISITE,PSOBEXFL F PSOVX=0:0 S PSOVX=$O(^PS(59,PSOVX)) Q:'PSOVX I $P($G(^PS(59,PSOVX,"I")),"^"),DT>$P($G(^("I")),"^") S PSOBEXI(PSOVX)=""
I $O(PSOBEXI(0)) W !,"Looking for refill requests for inactive Outpatient divisions..." F PSOVIN=0:0 S PSOVIN=$O(^VEXHRX(19080,PSOVIN)) Q:'PSOVIN S PSOVXLP="" F S PSOVXLP=$O(^VEXHRX(19080,PSOVIN,PSOVXLP)) Q:PSOVXLP="" D
.S PSOISITE=$P($G(^PSRX(+$P(PSOVXLP,"-",2),2)),"^",9) Q:$G(PSOBEXI(+$G(PSOISITE)))
.I PSOISITE,$D(PSOBEXI(PSOISITE)),$P($G(^VEXHRX(19080,PSOVIN,PSOVXLP)),U)="" S PSOBEXI(PSOISITE)=1,PSOBEXFL=1
I '$G(PSOBEXFL),$O(PSOBEXI(0)) W ".none found.",!
I $G(PSOBEXFL) W !!,"The following Inactive Outpatient sites have refill requests:",! F PSOVX=0:0 S PSOVX=$O(PSOBEXI(PSOVX)) Q:'PSOVX I $G(PSOBEXI(PSOVX)) W !?5,$P($G(^PS(59,+$G(PSOVX),0)),"^")
I $G(PSOBEXFL) K DIR W ! S DIR(0)="E",DIR("A")="Press Return to Continue, '^'to exit" D ^DIR W ! I Y'=1 G END
;
;
;IHS/BJI/DAY - Patch 6 - Improved Site Selection
;
;Store incoming Site values
D HOLD^BEXSITE
;
;Display site values to user and ask for change
D CHANGE^BEXSITE
;
;End Patch 6
;
S PSOBBC1("FROM")="REFILL",PSOBBC("QFLG")=0,PSOBBC("DFLG")=0
I '$G(PSOINST) S PSOINST=000 I $D(^DD("SITE",1)) S PSOINST=^DD("SITE",1) ;maw 9/9/02
S PSOFROM="REFILL"
I '$D(^VEXHRX(19080,PSOINST)) S BEXANS="N" W !!?7,$C(7),"No telephone refills to process." G END
D ASK^PSOBBC W:PSOBBC("QFLG")=1 !?7,$C(7),"No telephone refills were processed." G:PSOBBC("QFLG")=1 END
BEX I $$CUT G END
W ! S DIR("B")="YES",DIR("A")="Process telephone refill requests at this time",DIR(0)="Y" D ^DIR K DIR S BEXANS="N" I $G(DIRUT) S BEXPTRX="" G END
G:Y=0 END S BEXPTRX="" I Y=1 S BEXANS="Y"
;
;IHS/CMI/BJI - Patch 5 - Selection by division
K BEXOPSIT
S (BEXOPSIT,BEXQUIT,BEXEXIT)=0
I BEXANS="Y" D
.W !!,"Press Enter to process refills for ALL Outpatient Sites, or"
.F D Q:BEXQUIT=1
..K DIC,DIE,DUOUT,DA
..S DIC(0)="AEQMZ"
..S DIC("A")="Select an 'Outpatient Site': "
..S DIC=59
..D ^DIC
..K DIR,DIC,DIR,DR
..I $G(DUOUT) K DUOUT S (BEXQUIT,BEXEXIT)=1 Q
..I X="" S BEXQUIT=1 Q
..I Y<1 Q
..S BEXOPSIT=BEXOPSIT+1
..S BEXOPSIT(+Y)=""
;
I BEXEXIT=1 K DUOUT Q
;*
;
;IHS/CMI/BJI - Patch 5 - Limit to Mail, Local or Window
K DIR
S DIR(0)="S^A:All;L:Local;M:Mail;W:Window"
S DIR("A")="Process All, Local Mail, Mail, or Window"
D ^DIR
K DIR
I $D(DIRUT) K DIRUT S BEXANS="N" G END
S BEXMAIL=Y
W !
;*
;
S (BEXCTR,VEXCTR)=0
BEX6 S PSOBBC("DFLG")=""
I BEXANS["Y",$G(BEXPTRX) D BEX5
D BEX3 I $G(BEXANS)="N" D ULK G END
I $P(X,"-")'=PSOINST W !?7,$C(7),$C(7),$C(7),"Not from this institution.",! D ULK G BEX6
S (PSOBBC("IRXN"),PSOBBC("OIRXN"))=$P(X,"-",2)
S PSORX("PSOL",1)=$G(PSORX("PSOL",1))_PSOBBC("IRXN")_","
I $D(^PSRX(PSOBBC("IRXN"),0))']"" W !,$C(7),"Rx data is not on file!",! D ULK G BEX6
I $P($G(^PSRX(PSOBBC("IRXN"),"STA")),"^")=13 W !,$C(7),"Rx has already been deleted." D ULK G BEX6
I $G(PSOBBC("DONE"))[PSOBBC("IRXN")_"," W !,$C(7),"Rx has already been entered." D ULK G BEX6
K X,Y
S PSOSELSE=0 I $G(PSODFN)'=$P(^PSRX(PSOBBC("IRXN"),0),"^",2) D KSRX S PSOSELSE=1 D PT^PSOBBC I $G(PSOBBC("DFLG")) K PSOSELSE D ULK G BEX6
K PSOSELSE D PROFILE^PSORX1
W !!
;
;IHS/CMI/DAY - Patch 6 - Wrong Labs Display during refills
;
;Change recommended by Phil Salmon - January 2015
;
I +$G(PSODFN) S DFN=PSODFN
S PSODRUG("IEN")=$P(^PSRX(PSOBBC("IRXN"),0),U,6)
;
;End Patch 6
;*
;
S PSOBBC("DONE")=PSOBBC("IRXN")_"," D REFILL^PSOBBC D ULK G BEX6
Q
;
KSRX ;-- kill and reset PSORX
Q:$G(PSODFN)=""
K PSORX("PSOL",1)
S PSORX("PSOL",1)=PSOBBC("IRXN")_","
Q
;
BEX3 K PSOBBC("IRXN"),BEXXFLAG F S BEXPTRX=$O(^VEXHRX(19080,PSOINST,BEXPTRX)) D Q:BEXANS="N"!($G(BEXXFLAG))
.I BEXPTRX="" S BEXANS="N" Q
.I '$D(^PSRX(+$P(BEXPTRX,"-",2),0)),$P(^VEXHRX(19080,PSOINST,BEXPTRX),U)="" D BEX5,BEX12 Q ;SKIPS ERRONEOUS ENTRIES
BEX4 .I BEXANS["Y" Q:$P(^VEXHRX(19080,PSOINST,BEXPTRX),U)'="" S X=PSOINST_"-"_$P(BEXPTRX,"-",2)
.;
.;IHS/CMI/DAY - Screen by O/P Site
.;If quit, stay in loop and get next RX
.S BEXOPIEN=0
.S BEXRXIEN=+$P(BEXPTRX,"-",2)
.I +BEXRXIEN S BEXOPIEN=$P($G(^PSRX(BEXRXIEN,2)),"^",9)
.S BEXRFIEN=0
.I +BEXRXIEN S BEXRFIEN=$O(^PSRX(BEXRXIEN,1,99),-1)
.I +BEXRFIEN S BEXOPIEN=$P($G(^PSRX(BEXRXIEN,1,BEXRFIEN,0)),U,9)
.I +BEXOPSIT,+BEXOPIEN=0 Q
.I +BEXOPSIT,'$D(BEXOPSIT(BEXOPIEN)) Q
BEX10 .;
.;*
.;
.;IHS/CMI/DAY - Patch 5 - Limit for Mail, Local, Window
.S BEXFLAG=$G(^VEXHRX(19080,PSOINST,BEXPTRX))
.I BEXFLAG="" S BEXFLAG="^^^M"
.I $P(BEXFLAG,U,4)="M",BEXMAIL="W" Q
.I $P(BEXFLAG,U,4)="M",BEXMAIL="L" Q
.I $P(BEXFLAG,U,4)="L",BEXMAIL="W" Q
.I $P(BEXFLAG,U,4)="L",BEXMAIL="M" Q
.I $P(BEXFLAG,U,4)="W",BEXMAIL="L" Q
.I $P(BEXFLAG,U,4)="W",BEXMAIL="M" Q
.I $P(BEXFLAG,U,4)="M" S PSOBBC("MAIL/WINDOW")="M"
.I $P(BEXFLAG,U,4)="L" S PSOBBC("MAIL/WINDOW")="M"
.I $P(BEXFLAG,U,4)="W" S PSOBBC("MAIL/WINDOW")="W"
.;*
.;
.S BEXPSORX=+$P($G(BEXPTRX),"-",2) I BEXPSORX D PSOL^PSSLOCK(BEXPSORX) I '$G(PSOMSG) K BEXPSORX,PSOMSG Q
.K PSOMSG S BEXXFLAG=1
Q
;MARK PROCESSED NODES
BEX5 I '$G(PSOINST) S PSOINST=000 I $D(^DD("SITE",1)) S PSOINST=^DD("SITE",1)
S ^VEXHRX(19080,PSOINST,BEXPTRX)=DT
I $D(PSOBBC("DFLG")),PSOBBC("DFLG")=1 D BEX12
Q
BEX12 S $P(^VEXHRX(19080,PSOINST,BEXPTRX),U,2)="NOT FILLED" W !!,$C(7),"REFILL WAS NOT PROCESSED! PLEASE TAKE APPROPRIATE ACTION."
S PSOBBC("DFLG")=""
W ! S DIR("A")="Do you wish to continue processing",DIR(0)="Y" D ^DIR K DIR I Y'=1 S BEXANS="N" Q
Q
END D PROCESSX^PSOBBC
K BEXRX,BEXPPL,PSORX
I $P($G(^PS(59,+$G(PSOSITE),"I")),"^"),DT>$P($G(^("I")),"^") D FINAL^PSOLSET W !!,"Your Outpatient Site parameters have been deleted because you selected an",!,"inactive Outpatient Site!",!
K DIR,PSOBBC,PSOBBC1,PSOVIN,PSOISITE,PSOBEXFL,PSOVXLP,PSOBEX,PSOVX,PSOBEXI,BEXANS,BEXANS2,BEXPTRX,BEXXFLAG,BEXPSORX,X,Y,PSODFN
;
;IHS/BJI/DAY - Patch 6 - Check if User Changed Sites
;
;Check if Inactive Site was deleted
;
I $G(PSOSITE)="" K BEXHOLD D ^PSOLSET Q
I $G(PSOPAR)="" K BEXHOLD D ^PSOLSET Q
;
;Check if User Changed Sites
;
I $$CHECK^BEXSITE() D
.;
.W !!
.W "You may have changed your Outpatient Site!",!
.D CHANGE^BEXSITE
.;
.K BEXHOLD
;
;End Patch 6
;
Q
;
BEXALT ;Menu action entry point to alert user
S BEXCNT=0,BEXPTRN=""
I '$G(PSOINST) S PSOINST="000" I $D(^DD("SITE",1)) S PSOINST=^(1)
G:'$D(^VEXHRX(19080,PSOINST)) BEXEND
F S BEXPTRN=$O(^VEXHRX(19080,PSOINST,BEXPTRN)) Q:BEXPTRN="" D
.I $P(^VEXHRX(19080,PSOINST,BEXPTRN),U)="" S BEXCNT=BEXCNT+1
W:BEXCNT !!,$C(7),BEXCNT_" Telephone Refills To Process"
BEXEND K BEXCNT,BEXPTRN
Q
ULK ;
I '$G(BEXPSORX) Q
D PSOUL^PSSLOCK(BEXPSORX)
K BEXPSORX
Q
;
CUT() ;check cutoff time and now
S VSITEO=$O(^BEXHRXP("B",DUZ(2),0))
I '$G(VSITEO) Q 0
S VSITE=$P($G(^BEXHRXP(VSITEO,0)),U)
I '$G(VSITE) Q 0
S VCUT=$P($G(^BEXHRXP(VSITEO,0)),U,3)
I '$G(VCUT) Q 0
D NOW^%DTC
I $E($P(%,".",2),1,4)>+$G(VCUT) D Q 1
. W !,"Process time is past daily cut off time, refills will not be processed"
Q 0
;
CR(BEXVIEN) ;EP - add a chart request
I $G(U)="" S U="^"
I $P($G(^VEXHRX0(19080.1,BEXVIEN,0)),U,5)="" Q
S BEXPAT=$P($G(^VEXHRX0(19080.1,BEXVIEN,0)),U)
I '$G(BEXPAT) Q
S BEXTS=$P($G(^VEXHRX0(19080.1,BEXVIEN,0)),U,2)
;
;IHS/BJI/DAY - Patch 6
;Fix Site Lookup to use D Xref instead of C Xref
;I '$G(DUZ(2)) S DUZ(2)=$P($G(^AUTTSITE(1,0)),U)
;S BEXPSITE=$O(^PS(59,"C",DUZ(2),0))
;I '$G(BEXPSITE) S DUZ(2)=$P($G(^AUTTSITE(1,0)),U)
;S BEXPSITE=$O(^PS(59,"C",DUZ(2),0))
S BEXPSITE=""
I +$G(DUZ(2)) S BEXPSITE=$O(^PS(59,"D",DUZ(2),0))
;End Patch
;
I '$G(BEXPSITE) Q
S BEXVSITO=$O(^BEXHRXP("B",BEXPSITE,0))
I '$G(BEXVSITO) Q
S BEXVSITE=$P($G(^BEXHRXP(BEXVSITO,0)),U)
I '$G(BEXVSITE) Q
;site screen
N BEXSLOC
S BEXSLOC=$P($G(^VEXHRX0(19080.1,BEXVIEN,0)),U,10)
;
;IHS/CMI/DAY - Patch 4 - P10 not always set, so calculate manually
I BEXSLOC="" D
.;Get Prescription Number
.S Y=$P($G(^VEXHRX0(19080.1,BEXVIEN,0)),U,3)
.I Y="" Q
.;Get IEN in Prescription file
.S BEXRXIEN=$O(^PSRX("B",Y,0))
.I BEXRXIEN="" Q
.;Get Division (O/P Site) from Prescription File
.S Y=$$GET1^DIQ(52,BEXRXIEN,20,"I")
.I Y="" Q
.;Get Related Institution from Outpatient Site file
.S Y=$$GET1^DIQ(59,Y,100,"I")
.I Y="" Q
.S BEXSLOC=Y
;
I $G(BEXSLOC)]"",BEXSLOC'=DUZ(2) Q
;
S BEXTSCA=$P($G(^BEXHRXP(BEXVSITO,0)),U,7)
S BEXTSRA=$P($G(^BEXHRXP(BEXVSITO,0)),U,8)
S BEXTSRP=$P($G(^BEXHRXP(BEXVSITO,0)),U,9)
I '$G(BEXTS) S BEXTS=DT_".08"
S BEXOTM=$E($P(BEXTS,".",2),1,4)
I BEXOTM=0 Q
I $L(BEXOTM)=1 S BEXOTM=BEXOTM_"000"
I $L(BEXOTM)=2 S BEXOTM=BEXOTM_"00"
I $L(BEXOTM)=3 S BEXOTM=BEXOTM_"0"
S BEXTSP=$P(BEXTS,".")_"."_$S($G(BEXTSRP):BEXTSRP,1:2000)
S BEXTSP=+BEXTSP
S BEXTS=$P(BEXTS,".")_"."_$S($G(BEXTSRA):BEXTSRA,1:"08")
S BEXTS=+BEXTS
S BEXCLNA=$P($G(^BEXHRXP(BEXVSITO,0)),U,4)
S BEXCLNB=$P($G(^BEXHRXP(BEXVSITO,0)),U,5)
S BEXCUT=$P($G(^BEXHRXP(BEXVSITO,0)),U,3)
S BEXREFO=$P($G(^BEXHRXP(BEXVSITO,0)),U,2)
I '$G(BEXCLNA) S BEXCLNA=BEXCLNB ;for blank am clinic
I '$G(BEXCLNA) Q
I '$D(^DPT(BEXPAT,0)) Q
S BEXCLNI=BEXCLNA
S BEXPM=0
I $G(BEXCUT),$G(BEXCLNB) D
. I (BEXOTM>BEXCUT)!(BEXOTM<BEXTSCA) S BEXCLNI=BEXCLNB,BEXTS=BEXTSP,BEXPM=1
I 'BEXCLNI S BEXCLNI=BEXCLNA
I 'BEXCLNI Q
;mark routing slip as printed
I $G(BEXREFO),$P($G(^VEXHRX0(19080.1,BEXVIEN,0)),U,5)'="REFILLABLE" Q
I $$PIMS53 D ADDCR(BEXCLNI,BEXPAT,BEXTS,+$G(BEXPM)),MARK(BEXVIEN) Q
I $$LKPT(BEXPAT,BEXCLNI,BEXTS) Q
I '$D(^SC(BEXCLNI,"S",BEXTS,0)) D
. S ^SC(BEXCLNI,"S",BEXTS,0)=BEXTS
I '$D(^SC(BEXCLNI,"S",BEXTS,1,0)) D
. S ^SC(BEXCLNI,"S",BEXTS,1,0)="^44.003PA^^"
S BEXNXT=$$GNXT(BEXCLNI,BEXTS)
S ^SC(BEXCLNI,"S",BEXTS,1,BEXNXT,0)=BEXPAT_U_U_U_"PHARMACY CHART REQUEST (TA)"
S ^SC(BEXCLNI,"S",BEXTS,1,BEXNXT,"C")=BEXTS
I '$D(^DPT(BEXPAT,"S",0)) D
. S ^DPT(BEXPAT,"S",0)="^2.98^^"
S BEXAPTP=$O(^SD(409.1,"B","COMPUTER GENERATED",0))
S ^DPT(BEXPAT,"S",BEXTS,0)=BEXCLNI_U_U_U_U_U_U_U_U_U_U_U_U_U_U_U_$G(BEXAPTP)
D RS(BEXPAT,BEXCLNI)
D MARK(BEXVIEN)
Q
;
PIMS53() ;check for pims 5.3
N BEXPIMS
S BEXPIMS=$O(^DIC(9.4,"C","PIMS",0))
I '$G(BEXPIMS) Q 0
I $G(^DIC(9.4,BEXPIMS,"VERSION"))>5.29 Q 1
Q 0
;
ADDCR(CLN,PAT,TS,PM) ;-- add cr and print rs
S BEXTSO=TS
S TS=$P(TS,".")
Q:$O(^SC("AIHSCR",PAT,CLN,TS,0)) ;quit if chart request there already
N BEXIENS,BEXERR,BEXFDA,BEXDATE,BEXNOW,BEXCLNE,BEXDEV
S BEXIENS=""
S BEXIENS(1)=CLN
S BEXIENS(2)=TS
;
S BEXCLNE=$P($G(^SC(CLN,0)),U)
S BEXFDA(44.006,"?+2,"_BEXIENS(1)_",",.01)=TS
S BEXFDA(44.007,"?+3,?+2,"_BEXIENS(1)_",",.01)=PAT
S BEXFDA(44.007,"?+3,?+2,"_BEXIENS(1)_",",9999999.01)=BEXTSO
S BEXFDA(44.007,"?+3,?+2,"_BEXIENS(1)_",",9999999.02)=$G(DUZ)
S BEXFDA(44.007,"?+3,?+2,"_BEXIENS(1)_",",9999999.03)="Audiocare Telephone Refill"
S BEXFDA(44.007,"?+3,?+2,"_BEXIENS(1)_",",9999999.04)=$$NOW^XLFDT()
D UPDATE^DIE("","BEXFDA","BEXIENS","BEXERR(1)")
Q:$D(BEXERR)
I $G(PM) D
. S BEXDEV=$$GET1^DIQ(90350.2,BEXVSITO,2)
I $G(BEXDEV)="" S BEXDEV=$$GET1^DIQ(90350.2,BEXVSITO,1)
Q:BEXDEV=""
S DGQUIET=1
D WISD^BSDROUT(PAT,$P(TS,"."),"CR",BEXDEV)
Q
;
ADDDPT(CLN,PAT,TS) ;-- add the appointment to the patient file
N BEXIENS,BEXERR,BEXFDA,BEXDATE,BEXNOW,BEXPATE,BEXAPTP
S BEXAPTP=$O(^SD(409.1,"B","COMPUTER GENERATED",0))
S BEXIENS=""
S BEXIENS(1)=PAT
S BEXIENS(2)=TS
S BEXPATE=$P($G(^DPT(PAT,0)),U)
S BEXFDA(2.98,"?+2,"_BEXIENS(1)_",",.01)=CLN
S BEXFDA(2.98,"?+2,"_BEXIENS(1)_",",8)=DT
S BEXFDA(2.98,"?+2,"_BEXIENS(1)_",",9.5)=BEXAPTP
D UPDATE^DIE("","BEXFDA","BEXIENS","BEXERR(1)")
Q:$D(BEXERR)
Q
;
RS(DFN,CI) ;-- print a routine slip
Q:'$P($G(^BEXHRXP(BEXVSITO,0)),U,6)
S VAR="DIV^ORDER^SDX^DFN^SDREP^SDSTART^SDZHS^ASDLONG^SDZSC^SDZCV^SDPR",DGPGM="EN1^SDROUT1"
;
S BEXDEV=$$GET1^DIQ(90350.2,BEXVSITO,1)
I $G(BEXDEV)="" Q
S DIV=$P($G(^SC(CI,0)),U,15) ;for routing slip
S (SDZZWI,SDZCV,DGUTQND)=1
S IOP=BEXDEV,POP=0,%ZIS="Q" D ^%ZIS Q:$G(POP)
;D ^%ZIS ;for testing
;
D EN^XBNEW("Q1^DGUTQ","SD*;DFN;DG*;DIV;VAR;IO*")
Q
;
LKPT(PT,CI,TM) ;-- check if patient has cr already
K BEXCRE
S BEXIEN=0 F S BEXIEN=$O(^SC(CI,"S",TM,1,BEXIEN)) Q:'BEXIEN D
. I $P($G(^SC(CI,"S",TM,1,BEXIEN,0)),U)=PT S BEXCRE=1 Q
Q $G(BEXCRE)
;
GNXT(CI,TM) ;-- get next ien for clinic
K BEXNXT
S BEXIEN=0 F S BEXIEN=$O(^SC(CI,"S",TM,1,BEXIEN)) Q:'BEXIEN D
. S BEXNXT=BEXIEN
Q $G(BEXNXT)+1
;
EOJCR ;-- kill vars
D EN^XBVK("SD")
D EN^XBVK("BEX")
D EN^XBVK("VSIT")
D EN^XBVK("CLN")
K OTM,PAT,TS,TSM,TSCA,TSCP
Q
;
TSK ;EP - loop trans file and request charts
D ^XBKVAR
S BEXRDA=0 F S BEXRDA=$O(^VEXHRX0(19080.1,BEXRDA)) Q:'BEXRDA D
. Q:$P($G(^VEXHRX0(19080.1,BEXRDA,0)),U,9)
. D CR(BEXRDA)
Q
;
MARK(BEXRDA) ;EP - mark entries as completed
N BEXFDA,BEXIENS,BEXERR
S BEXIENS=BEXRDA_","
S BEXFDA(90350.1,BEXIENS,9)=1
D UPDATE^DIE("","BEXFDA","BEXIENS","BEXERR(1)")
D EOJCR
Q
;
IDX ;EP - reindex all x ref upon entry into menu
W !!,"I need to update files, please stand by.."
S DIK="^VEXHRX0(19080.1," D IXALL^DIK
K DIK
Q
;
DIE ;EP
S DIE="^VEXHRX0(19080.1,"
S BEXIDA=0 F S BEXIDA=$O(^VEXHRX0(19080.1,"C",BEXIDA)) Q:BEXIDA="" D
. S BEXIIEN=0 F S BEXIIEN=$O(^VEXHRX0(19080.1,"C",BEXIDA,BEXIIEN)) Q:'BEXIIEN D
.. S BEXIDT=$P($G(BEXIDA),".")
.. Q:$P($G(BEXIDA),".",2)'=0
.. S BEXNIDT=BEXIDT_".12"
.. S BEXNIDT=+BEXNIDT
.. S BEXEIDT=$$FMTE^XLFDT(BEXNIDT)
.. S DA=BEXIIEN,DR="1///"_BEXEIDT
.. D ^DIE
.. K DR,DA
K DIE,BEXIDA,BEXNIDT,BEXIIEN
Q
;
HDR ;EP
S BEXPKG="BEXR Audiocare Pharmacy Refill System"
S BEXLOC="Location: "_$P($G(^DIC(4,DUZ(2),0)),U)
S BEXTAB=(80-$L(BEXLOC))/2
W !,?(80-$L(BEXPKG))/2,BEXPKG
W !,?BEXTAB,BEXLOC
Q
;
MED ;-- populate 90350.1 with med name in 11th piece
N BEXDA
S BEXDA=0 F S BEXDA=$O(^VEXHRX0(19080.1,BEXDA)) Q:'BEXDA D
. Q:$P($G(^VEXHRX0(19080.1,BEXDA,0)),U,11)
. N BEXRX,BEXRXI,BEXDRG
. S BEXRX=$P($G(^VEXHRX0(19080.1,BEXDA,0)),U,3)
. Q:'BEXRX
. S BEXRXI=$O(^PSRX("B",BEXRX,0))
. Q:'BEXRXI
. S BEXDRG=$P($G(^PSRX(BEXRXI,0)),U,6)
. Q:'BEXDRG
. N BEXFDA,BEXIEN,BEXERR
. S BEXIEN=BEXDA_","
. S BEXFDA(90350.1,BEXIEN,11)=BEXDRG
. D FILE^DIE("K","BEXFDA","BEXERR(1)")
Q
;
BEXRX7 ;cmi/anch/maw - BEX Audiocare Refill Driver - Pharmacy Version 7 Only [ 06/15/2010 9:18 PM ] ; 04 Dec 2015 8:08 AM
+1 ;;1.0;BEX TELEPHONE REFILL SYSTEM;**1,2,4,5,6**;APR 20, 2015;Build 7
+2 ;For O/P V7 only
+3 ;
+4 ;
START ;
+1 SET PSOBEX=1
+2 SET (VEXRX,BEXRX)=1
+3 KILL PSOBEXI,PSOISITE,PSOBEXFL
FOR PSOVX=0:0
SET PSOVX=$ORDER(^PS(59,PSOVX))
IF 'PSOVX
QUIT
IF $PIECE($GET(^PS(59,PSOVX,"I")),"^")
IF DT>$PIECE($GET(^("I")),"^")
SET PSOBEXI(PSOVX)=""
+4 IF $ORDER(PSOBEXI(0))
WRITE !,"Looking for refill requests for inactive Outpatient divisions..."
FOR PSOVIN=0:0
SET PSOVIN=$ORDER(^VEXHRX(19080,PSOVIN))
IF 'PSOVIN
QUIT
SET PSOVXLP=""
FOR
SET PSOVXLP=$ORDER(^VEXHRX(19080,PSOVIN,PSOVXLP))
IF PSOVXLP=""
QUIT
Begin DoDot:1
+5 SET PSOISITE=$PIECE($GET(^PSRX(+$PIECE(PSOVXLP,"-",2),2)),"^",9)
IF $GET(PSOBEXI(+$GET(PSOISITE)))
QUIT
+6 IF PSOISITE
IF $DATA(PSOBEXI(PSOISITE))
IF $PIECE($GET(^VEXHRX(19080,PSOVIN,PSOVXLP)),U)=""
SET PSOBEXI(PSOISITE)=1
SET PSOBEXFL=1
End DoDot:1
+7 IF '$GET(PSOBEXFL)
IF $ORDER(PSOBEXI(0))
WRITE ".none found.",!
+8 IF $GET(PSOBEXFL)
WRITE !!,"The following Inactive Outpatient sites have refill requests:",!
FOR PSOVX=0:0
SET PSOVX=$ORDER(PSOBEXI(PSOVX))
IF 'PSOVX
QUIT
IF $GET(PSOBEXI(PSOVX))
WRITE !?5,$PIECE($GET(^PS(59,+$GET(PSOVX),0)),"^")
+9 IF $GET(PSOBEXFL)
KILL DIR
WRITE !
SET DIR(0)="E"
SET DIR("A")="Press Return to Continue, '^'to exit"
DO ^DIR
WRITE !
IF Y'=1
GOTO END
+10 ;
+11 ;
+12 ;IHS/BJI/DAY - Patch 6 - Improved Site Selection
+13 ;
+14 ;Store incoming Site values
+15 DO HOLD^BEXSITE
+16 ;
+17 ;Display site values to user and ask for change
+18 DO CHANGE^BEXSITE
+19 ;
+20 ;End Patch 6
+21 ;
+22 SET PSOBBC1("FROM")="REFILL"
SET PSOBBC("QFLG")=0
SET PSOBBC("DFLG")=0
+23 ;maw 9/9/02
IF '$GET(PSOINST)
SET PSOINST=000
IF $DATA(^DD("SITE",1))
SET PSOINST=^DD("SITE",1)
+24 SET PSOFROM="REFILL"
+25 IF '$DATA(^VEXHRX(19080,PSOINST))
SET BEXANS="N"
WRITE !!?7,$CHAR(7),"No telephone refills to process."
GOTO END
+26 DO ASK^PSOBBC
IF PSOBBC("QFLG")=1
WRITE !?7,$CHAR(7),"No telephone refills were processed."
IF PSOBBC("QFLG")=1
GOTO END
BEX IF $$CUT
GOTO END
+1 WRITE !
SET DIR("B")="YES"
SET DIR("A")="Process telephone refill requests at this time"
SET DIR(0)="Y"
DO ^DIR
KILL DIR
SET BEXANS="N"
IF $GET(DIRUT)
SET BEXPTRX=""
GOTO END
+2 IF Y=0
GOTO END
SET BEXPTRX=""
IF Y=1
SET BEXANS="Y"
+3 ;
+4 ;IHS/CMI/BJI - Patch 5 - Selection by division
+5 KILL BEXOPSIT
+6 SET (BEXOPSIT,BEXQUIT,BEXEXIT)=0
+7 IF BEXANS="Y"
Begin DoDot:1
+8 WRITE !!,"Press Enter to process refills for ALL Outpatient Sites, or"
+9 FOR
Begin DoDot:2
+10 KILL DIC,DIE,DUOUT,DA
+11 SET DIC(0)="AEQMZ"
+12 SET DIC("A")="Select an 'Outpatient Site': "
+13 SET DIC=59
+14 DO ^DIC
+15 KILL DIR,DIC,DIR,DR
+16 IF $GET(DUOUT)
KILL DUOUT
SET (BEXQUIT,BEXEXIT)=1
QUIT
+17 IF X=""
SET BEXQUIT=1
QUIT
+18 IF Y<1
QUIT
+19 SET BEXOPSIT=BEXOPSIT+1
+20 SET BEXOPSIT(+Y)=""
End DoDot:2
IF BEXQUIT=1
QUIT
End DoDot:1
+21 ;
+22 IF BEXEXIT=1
KILL DUOUT
QUIT
+23 ;*
+24 ;
+25 ;IHS/CMI/BJI - Patch 5 - Limit to Mail, Local or Window
+26 KILL DIR
+27 SET DIR(0)="S^A:All;L:Local;M:Mail;W:Window"
+28 SET DIR("A")="Process All, Local Mail, Mail, or Window"
+29 DO ^DIR
+30 KILL DIR
+31 IF $DATA(DIRUT)
KILL DIRUT
SET BEXANS="N"
GOTO END
+32 SET BEXMAIL=Y
+33 WRITE !
+34 ;*
+35 ;
+36 SET (BEXCTR,VEXCTR)=0
BEX6 SET PSOBBC("DFLG")=""
+1 IF BEXANS["Y"
IF $GET(BEXPTRX)
DO BEX5
+2 DO BEX3
IF $GET(BEXANS)="N"
DO ULK
GOTO END
+3 IF $PIECE(X,"-")'=PSOINST
WRITE !?7,$CHAR(7),$CHAR(7),$CHAR(7),"Not from this institution.",!
DO ULK
GOTO BEX6
+4 SET (PSOBBC("IRXN"),PSOBBC("OIRXN"))=$PIECE(X,"-",2)
+5 SET PSORX("PSOL",1)=$GET(PSORX("PSOL",1))_PSOBBC("IRXN")_","
+6 IF $DATA(^PSRX(PSOBBC("IRXN"),0))']""
WRITE !,$CHAR(7),"Rx data is not on file!",!
DO ULK
GOTO BEX6
+7 IF $PIECE($GET(^PSRX(PSOBBC("IRXN"),"STA")),"^")=13
WRITE !,$CHAR(7),"Rx has already been deleted."
DO ULK
GOTO BEX6
+8 IF $GET(PSOBBC("DONE"))[PSOBBC("IRXN")_","
WRITE !,$CHAR(7),"Rx has already been entered."
DO ULK
GOTO BEX6
+9 KILL X,Y
+10 SET PSOSELSE=0
IF $GET(PSODFN)'=$PIECE(^PSRX(PSOBBC("IRXN"),0),"^",2)
DO KSRX
SET PSOSELSE=1
DO PT^PSOBBC
IF $GET(PSOBBC("DFLG"))
KILL PSOSELSE
DO ULK
GOTO BEX6
+11 KILL PSOSELSE
DO PROFILE^PSORX1
+12 WRITE !!
+13 ;
+14 ;IHS/CMI/DAY - Patch 6 - Wrong Labs Display during refills
+15 ;
+16 ;Change recommended by Phil Salmon - January 2015
+17 ;
+18 IF +$GET(PSODFN)
SET DFN=PSODFN
+19 SET PSODRUG("IEN")=$PIECE(^PSRX(PSOBBC("IRXN"),0),U,6)
+20 ;
+21 ;End Patch 6
+22 ;*
+23 ;
+24 SET PSOBBC("DONE")=PSOBBC("IRXN")_","
DO REFILL^PSOBBC
DO ULK
GOTO BEX6
+25 QUIT
+26 ;
KSRX ;-- kill and reset PSORX
+1 IF $GET(PSODFN)=""
QUIT
+2 KILL PSORX("PSOL",1)
+3 SET PSORX("PSOL",1)=PSOBBC("IRXN")_","
+4 QUIT
+5 ;
BEX3 KILL PSOBBC("IRXN"),BEXXFLAG
FOR
SET BEXPTRX=$ORDER(^VEXHRX(19080,PSOINST,BEXPTRX))
Begin DoDot:1
+1 IF BEXPTRX=""
SET BEXANS="N"
QUIT
+2 ;SKIPS ERRONEOUS ENTRIES
IF '$DATA(^PSRX(+$PIECE(BEXPTRX,"-",2),0))
IF $PIECE(^VEXHRX(19080,PSOINST,BEXPTRX),U)=""
DO BEX5
DO BEX12
QUIT
BEX4 IF BEXANS["Y"
IF $PIECE(^VEXHRX(19080,PSOINST,BEXPTRX),U)'=""
QUIT
SET X=PSOINST_"-"_$PIECE(BEXPTRX,"-",2)
+1 ;
+2 ;IHS/CMI/DAY - Screen by O/P Site
+3 ;If quit, stay in loop and get next RX
+4 SET BEXOPIEN=0
+5 SET BEXRXIEN=+$PIECE(BEXPTRX,"-",2)
+6 IF +BEXRXIEN
SET BEXOPIEN=$PIECE($GET(^PSRX(BEXRXIEN,2)),"^",9)
+7 SET BEXRFIEN=0
+8 IF +BEXRXIEN
SET BEXRFIEN=$ORDER(^PSRX(BEXRXIEN,1,99),-1)
+9 IF +BEXRFIEN
SET BEXOPIEN=$PIECE($GET(^PSRX(BEXRXIEN,1,BEXRFIEN,0)),U,9)
+10 IF +BEXOPSIT
IF +BEXOPIEN=0
QUIT
+11 IF +BEXOPSIT
IF '$DATA(BEXOPSIT(BEXOPIEN))
QUIT
BEX10 ;
+1 ;*
+2 ;
+3 ;IHS/CMI/DAY - Patch 5 - Limit for Mail, Local, Window
+4 SET BEXFLAG=$GET(^VEXHRX(19080,PSOINST,BEXPTRX))
+5 IF BEXFLAG=""
SET BEXFLAG="^^^M"
+6 IF $PIECE(BEXFLAG,U,4)="M"
IF BEXMAIL="W"
QUIT
+7 IF $PIECE(BEXFLAG,U,4)="M"
IF BEXMAIL="L"
QUIT
+8 IF $PIECE(BEXFLAG,U,4)="L"
IF BEXMAIL="W"
QUIT
+9 IF $PIECE(BEXFLAG,U,4)="L"
IF BEXMAIL="M"
QUIT
+10 IF $PIECE(BEXFLAG,U,4)="W"
IF BEXMAIL="L"
QUIT
+11 IF $PIECE(BEXFLAG,U,4)="W"
IF BEXMAIL="M"
QUIT
+12 IF $PIECE(BEXFLAG,U,4)="M"
SET PSOBBC("MAIL/WINDOW")="M"
+13 IF $PIECE(BEXFLAG,U,4)="L"
SET PSOBBC("MAIL/WINDOW")="M"
+14 IF $PIECE(BEXFLAG,U,4)="W"
SET PSOBBC("MAIL/WINDOW")="W"
+15 ;*
+16 ;
+17 SET BEXPSORX=+$PIECE($GET(BEXPTRX),"-",2)
IF BEXPSORX
DO PSOL^PSSLOCK(BEXPSORX)
IF '$GET(PSOMSG)
KILL BEXPSORX,PSOMSG
QUIT
+18 KILL PSOMSG
SET BEXXFLAG=1
End DoDot:1
IF BEXANS="N"!($GET(BEXXFLAG))
QUIT
+19 QUIT
+20 ;MARK PROCESSED NODES
BEX5 IF '$GET(PSOINST)
SET PSOINST=000
IF $DATA(^DD("SITE",1))
SET PSOINST=^DD("SITE",1)
+1 SET ^VEXHRX(19080,PSOINST,BEXPTRX)=DT
+2 IF $DATA(PSOBBC("DFLG"))
IF PSOBBC("DFLG")=1
DO BEX12
+3 QUIT
BEX12 SET $PIECE(^VEXHRX(19080,PSOINST,BEXPTRX),U,2)="NOT FILLED"
WRITE !!,$CHAR(7),"REFILL WAS NOT PROCESSED! PLEASE TAKE APPROPRIATE ACTION."
+1 SET PSOBBC("DFLG")=""
+2 WRITE !
SET DIR("A")="Do you wish to continue processing"
SET DIR(0)="Y"
DO ^DIR
KILL DIR
IF Y'=1
SET BEXANS="N"
QUIT
+3 QUIT
END DO PROCESSX^PSOBBC
+1 KILL BEXRX,BEXPPL,PSORX
+2 IF $PIECE($GET(^PS(59,+$GET(PSOSITE),"I")),"^")
IF DT>$PIECE($GET(^("I")),"^")
DO FINAL^PSOLSET
WRITE !!,"Your Outpatient Site parameters have been deleted because you selected an",!,"inactive Outpatient Site!",!
+3 KILL DIR,PSOBBC,PSOBBC1,PSOVIN,PSOISITE,PSOBEXFL,PSOVXLP,PSOBEX,PSOVX,PSOBEXI,BEXANS,BEXANS2,BEXPTRX,BEXXFLAG,BEXPSORX,X,Y,PSODFN
+4 ;
+5 ;IHS/BJI/DAY - Patch 6 - Check if User Changed Sites
+6 ;
+7 ;Check if Inactive Site was deleted
+8 ;
+9 IF $GET(PSOSITE)=""
KILL BEXHOLD
DO ^PSOLSET
QUIT
+10 IF $GET(PSOPAR)=""
KILL BEXHOLD
DO ^PSOLSET
QUIT
+11 ;
+12 ;Check if User Changed Sites
+13 ;
+14 IF $$CHECK^BEXSITE()
Begin DoDot:1
+15 ;
+16 WRITE !!
+17 WRITE "You may have changed your Outpatient Site!",!
+18 DO CHANGE^BEXSITE
+19 ;
+20 KILL BEXHOLD
End DoDot:1
+21 ;
+22 ;End Patch 6
+23 ;
+24 QUIT
+25 ;
BEXALT ;Menu action entry point to alert user
+1 SET BEXCNT=0
SET BEXPTRN=""
+2 IF '$GET(PSOINST)
SET PSOINST="000"
IF $DATA(^DD("SITE",1))
SET PSOINST=^(1)
+3 IF '$DATA(^VEXHRX(19080,PSOINST))
GOTO BEXEND
+4 FOR
SET BEXPTRN=$ORDER(^VEXHRX(19080,PSOINST,BEXPTRN))
IF BEXPTRN=""
QUIT
Begin DoDot:1
+5 IF $PIECE(^VEXHRX(19080,PSOINST,BEXPTRN),U)=""
SET BEXCNT=BEXCNT+1
End DoDot:1
+6 IF BEXCNT
WRITE !!,$CHAR(7),BEXCNT_" Telephone Refills To Process"
BEXEND KILL BEXCNT,BEXPTRN
+1 QUIT
ULK ;
+1 IF '$GET(BEXPSORX)
QUIT
+2 DO PSOUL^PSSLOCK(BEXPSORX)
+3 KILL BEXPSORX
+4 QUIT
+5 ;
CUT() ;check cutoff time and now
+1 SET VSITEO=$ORDER(^BEXHRXP("B",DUZ(2),0))
+2 IF '$GET(VSITEO)
QUIT 0
+3 SET VSITE=$PIECE($GET(^BEXHRXP(VSITEO,0)),U)
+4 IF '$GET(VSITE)
QUIT 0
+5 SET VCUT=$PIECE($GET(^BEXHRXP(VSITEO,0)),U,3)
+6 IF '$GET(VCUT)
QUIT 0
+7 DO NOW^%DTC
+8 IF $EXTRACT($PIECE(%,".",2),1,4)>+$GET(VCUT)
Begin DoDot:1
+9 WRITE !,"Process time is past daily cut off time, refills will not be processed"
End DoDot:1
QUIT 1
+10 QUIT 0
+11 ;
CR(BEXVIEN) ;EP - add a chart request
+1 IF $GET(U)=""
SET U="^"
+2 IF $PIECE($GET(^VEXHRX0(19080.1,BEXVIEN,0)),U,5)=""
QUIT
+3 SET BEXPAT=$PIECE($GET(^VEXHRX0(19080.1,BEXVIEN,0)),U)
+4 IF '$GET(BEXPAT)
QUIT
+5 SET BEXTS=$PIECE($GET(^VEXHRX0(19080.1,BEXVIEN,0)),U,2)
+6 ;
+7 ;IHS/BJI/DAY - Patch 6
+8 ;Fix Site Lookup to use D Xref instead of C Xref
+9 ;I '$G(DUZ(2)) S DUZ(2)=$P($G(^AUTTSITE(1,0)),U)
+10 ;S BEXPSITE=$O(^PS(59,"C",DUZ(2),0))
+11 ;I '$G(BEXPSITE) S DUZ(2)=$P($G(^AUTTSITE(1,0)),U)
+12 ;S BEXPSITE=$O(^PS(59,"C",DUZ(2),0))
+13 SET BEXPSITE=""
+14 IF +$GET(DUZ(2))
SET BEXPSITE=$ORDER(^PS(59,"D",DUZ(2),0))
+15 ;End Patch
+16 ;
+17 IF '$GET(BEXPSITE)
QUIT
+18 SET BEXVSITO=$ORDER(^BEXHRXP("B",BEXPSITE,0))
+19 IF '$GET(BEXVSITO)
QUIT
+20 SET BEXVSITE=$PIECE($GET(^BEXHRXP(BEXVSITO,0)),U)
+21 IF '$GET(BEXVSITE)
QUIT
+22 ;site screen
+23 NEW BEXSLOC
+24 SET BEXSLOC=$PIECE($GET(^VEXHRX0(19080.1,BEXVIEN,0)),U,10)
+25 ;
+26 ;IHS/CMI/DAY - Patch 4 - P10 not always set, so calculate manually
+27 IF BEXSLOC=""
Begin DoDot:1
+28 ;Get Prescription Number
+29 SET Y=$PIECE($GET(^VEXHRX0(19080.1,BEXVIEN,0)),U,3)
+30 IF Y=""
QUIT
+31 ;Get IEN in Prescription file
+32 SET BEXRXIEN=$ORDER(^PSRX("B",Y,0))
+33 IF BEXRXIEN=""
QUIT
+34 ;Get Division (O/P Site) from Prescription File
+35 SET Y=$$GET1^DIQ(52,BEXRXIEN,20,"I")
+36 IF Y=""
QUIT
+37 ;Get Related Institution from Outpatient Site file
+38 SET Y=$$GET1^DIQ(59,Y,100,"I")
+39 IF Y=""
QUIT
+40 SET BEXSLOC=Y
End DoDot:1
+41 ;
+42 IF $GET(BEXSLOC)]""
IF BEXSLOC'=DUZ(2)
QUIT
+43 ;
+44 SET BEXTSCA=$PIECE($GET(^BEXHRXP(BEXVSITO,0)),U,7)
+45 SET BEXTSRA=$PIECE($GET(^BEXHRXP(BEXVSITO,0)),U,8)
+46 SET BEXTSRP=$PIECE($GET(^BEXHRXP(BEXVSITO,0)),U,9)
+47 IF '$GET(BEXTS)
SET BEXTS=DT_".08"
+48 SET BEXOTM=$EXTRACT($PIECE(BEXTS,".",2),1,4)
+49 IF BEXOTM=0
QUIT
+50 IF $LENGTH(BEXOTM)=1
SET BEXOTM=BEXOTM_"000"
+51 IF $LENGTH(BEXOTM)=2
SET BEXOTM=BEXOTM_"00"
+52 IF $LENGTH(BEXOTM)=3
SET BEXOTM=BEXOTM_"0"
+53 SET BEXTSP=$PIECE(BEXTS,".")_"."_$SELECT($GET(BEXTSRP):BEXTSRP,1:2000)
+54 SET BEXTSP=+BEXTSP
+55 SET BEXTS=$PIECE(BEXTS,".")_"."_$SELECT($GET(BEXTSRA):BEXTSRA,1:"08")
+56 SET BEXTS=+BEXTS
+57 SET BEXCLNA=$PIECE($GET(^BEXHRXP(BEXVSITO,0)),U,4)
+58 SET BEXCLNB=$PIECE($GET(^BEXHRXP(BEXVSITO,0)),U,5)
+59 SET BEXCUT=$PIECE($GET(^BEXHRXP(BEXVSITO,0)),U,3)
+60 SET BEXREFO=$PIECE($GET(^BEXHRXP(BEXVSITO,0)),U,2)
+61 ;for blank am clinic
IF '$GET(BEXCLNA)
SET BEXCLNA=BEXCLNB
+62 IF '$GET(BEXCLNA)
QUIT
+63 IF '$DATA(^DPT(BEXPAT,0))
QUIT
+64 SET BEXCLNI=BEXCLNA
+65 SET BEXPM=0
+66 IF $GET(BEXCUT)
IF $GET(BEXCLNB)
Begin DoDot:1
+67 IF (BEXOTM>BEXCUT)!(BEXOTM<BEXTSCA)
SET BEXCLNI=BEXCLNB
SET BEXTS=BEXTSP
SET BEXPM=1
End DoDot:1
+68 IF 'BEXCLNI
SET BEXCLNI=BEXCLNA
+69 IF 'BEXCLNI
QUIT
+70 ;mark routing slip as printed
+71 IF $GET(BEXREFO)
IF $PIECE($GET(^VEXHRX0(19080.1,BEXVIEN,0)),U,5)'="REFILLABLE"
QUIT
+72 IF $$PIMS53
DO ADDCR(BEXCLNI,BEXPAT,BEXTS,+$GET(BEXPM))
DO MARK(BEXVIEN)
QUIT
+73 IF $$LKPT(BEXPAT,BEXCLNI,BEXTS)
QUIT
+74 IF '$DATA(^SC(BEXCLNI,"S",BEXTS,0))
Begin DoDot:1
+75 SET ^SC(BEXCLNI,"S",BEXTS,0)=BEXTS
End DoDot:1
+76 IF '$DATA(^SC(BEXCLNI,"S",BEXTS,1,0))
Begin DoDot:1
+77 SET ^SC(BEXCLNI,"S",BEXTS,1,0)="^44.003PA^^"
End DoDot:1
+78 SET BEXNXT=$$GNXT(BEXCLNI,BEXTS)
+79 SET ^SC(BEXCLNI,"S",BEXTS,1,BEXNXT,0)=BEXPAT_U_U_U_"PHARMACY CHART REQUEST (TA)"
+80 SET ^SC(BEXCLNI,"S",BEXTS,1,BEXNXT,"C")=BEXTS
+81 IF '$DATA(^DPT(BEXPAT,"S",0))
Begin DoDot:1
+82 SET ^DPT(BEXPAT,"S",0)="^2.98^^"
End DoDot:1
+83 SET BEXAPTP=$ORDER(^SD(409.1,"B","COMPUTER GENERATED",0))
+84 SET ^DPT(BEXPAT,"S",BEXTS,0)=BEXCLNI_U_U_U_U_U_U_U_U_U_U_U_U_U_U_U_$GET(BEXAPTP)
+85 DO RS(BEXPAT,BEXCLNI)
+86 DO MARK(BEXVIEN)
+87 QUIT
+88 ;
PIMS53() ;check for pims 5.3
+1 NEW BEXPIMS
+2 SET BEXPIMS=$ORDER(^DIC(9.4,"C","PIMS",0))
+3 IF '$GET(BEXPIMS)
QUIT 0
+4 IF $GET(^DIC(9.4,BEXPIMS,"VERSION"))>5.29
QUIT 1
+5 QUIT 0
+6 ;
ADDCR(CLN,PAT,TS,PM) ;-- add cr and print rs
+1 SET BEXTSO=TS
+2 SET TS=$PIECE(TS,".")
+3 ;quit if chart request there already
IF $ORDER(^SC("AIHSCR",PAT,CLN,TS,0))
QUIT
+4 NEW BEXIENS,BEXERR,BEXFDA,BEXDATE,BEXNOW,BEXCLNE,BEXDEV
+5 SET BEXIENS=""
+6 SET BEXIENS(1)=CLN
+7 SET BEXIENS(2)=TS
+8 ;
+9 SET BEXCLNE=$PIECE($GET(^SC(CLN,0)),U)
+10 SET BEXFDA(44.006,"?+2,"_BEXIENS(1)_",",.01)=TS
+11 SET BEXFDA(44.007,"?+3,?+2,"_BEXIENS(1)_",",.01)=PAT
+12 SET BEXFDA(44.007,"?+3,?+2,"_BEXIENS(1)_",",9999999.01)=BEXTSO
+13 SET BEXFDA(44.007,"?+3,?+2,"_BEXIENS(1)_",",9999999.02)=$GET(DUZ)
+14 SET BEXFDA(44.007,"?+3,?+2,"_BEXIENS(1)_",",9999999.03)="Audiocare Telephone Refill"
+15 SET BEXFDA(44.007,"?+3,?+2,"_BEXIENS(1)_",",9999999.04)=$$NOW^XLFDT()
+16 DO UPDATE^DIE("","BEXFDA","BEXIENS","BEXERR(1)")
+17 IF $DATA(BEXERR)
QUIT
+18 IF $GET(PM)
Begin DoDot:1
+19 SET BEXDEV=$$GET1^DIQ(90350.2,BEXVSITO,2)
End DoDot:1
+20 IF $GET(BEXDEV)=""
SET BEXDEV=$$GET1^DIQ(90350.2,BEXVSITO,1)
+21 IF BEXDEV=""
QUIT
+22 SET DGQUIET=1
+23 DO WISD^BSDROUT(PAT,$PIECE(TS,"."),"CR",BEXDEV)
+24 QUIT
+25 ;
ADDDPT(CLN,PAT,TS) ;-- add the appointment to the patient file
+1 NEW BEXIENS,BEXERR,BEXFDA,BEXDATE,BEXNOW,BEXPATE,BEXAPTP
+2 SET BEXAPTP=$ORDER(^SD(409.1,"B","COMPUTER GENERATED",0))
+3 SET BEXIENS=""
+4 SET BEXIENS(1)=PAT
+5 SET BEXIENS(2)=TS
+6 SET BEXPATE=$PIECE($GET(^DPT(PAT,0)),U)
+7 SET BEXFDA(2.98,"?+2,"_BEXIENS(1)_",",.01)=CLN
+8 SET BEXFDA(2.98,"?+2,"_BEXIENS(1)_",",8)=DT
+9 SET BEXFDA(2.98,"?+2,"_BEXIENS(1)_",",9.5)=BEXAPTP
+10 DO UPDATE^DIE("","BEXFDA","BEXIENS","BEXERR(1)")
+11 IF $DATA(BEXERR)
QUIT
+12 QUIT
+13 ;
RS(DFN,CI) ;-- print a routine slip
+1 IF '$PIECE($GET(^BEXHRXP(BEXVSITO,0)),U,6)
QUIT
+2 SET VAR="DIV^ORDER^SDX^DFN^SDREP^SDSTART^SDZHS^ASDLONG^SDZSC^SDZCV^SDPR"
SET DGPGM="EN1^SDROUT1"
+3 ;
+4 SET BEXDEV=$$GET1^DIQ(90350.2,BEXVSITO,1)
+5 IF $GET(BEXDEV)=""
QUIT
+6 ;for routing slip
SET DIV=$PIECE($GET(^SC(CI,0)),U,15)
+7 SET (SDZZWI,SDZCV,DGUTQND)=1
+8 SET IOP=BEXDEV
SET POP=0
SET %ZIS="Q"
DO ^%ZIS
IF $GET(POP)
QUIT
+9 ;D ^%ZIS ;for testing
+10 ;
+11 DO EN^XBNEW("Q1^DGUTQ","SD*;DFN;DG*;DIV;VAR;IO*")
+12 QUIT
+13 ;
LKPT(PT,CI,TM) ;-- check if patient has cr already
+1 KILL BEXCRE
+2 SET BEXIEN=0
FOR
SET BEXIEN=$ORDER(^SC(CI,"S",TM,1,BEXIEN))
IF 'BEXIEN
QUIT
Begin DoDot:1
+3 IF $PIECE($GET(^SC(CI,"S",TM,1,BEXIEN,0)),U)=PT
SET BEXCRE=1
QUIT
End DoDot:1
+4 QUIT $GET(BEXCRE)
+5 ;
GNXT(CI,TM) ;-- get next ien for clinic
+1 KILL BEXNXT
+2 SET BEXIEN=0
FOR
SET BEXIEN=$ORDER(^SC(CI,"S",TM,1,BEXIEN))
IF 'BEXIEN
QUIT
Begin DoDot:1
+3 SET BEXNXT=BEXIEN
End DoDot:1
+4 QUIT $GET(BEXNXT)+1
+5 ;
EOJCR ;-- kill vars
+1 DO EN^XBVK("SD")
+2 DO EN^XBVK("BEX")
+3 DO EN^XBVK("VSIT")
+4 DO EN^XBVK("CLN")
+5 KILL OTM,PAT,TS,TSM,TSCA,TSCP
+6 QUIT
+7 ;
TSK ;EP - loop trans file and request charts
+1 DO ^XBKVAR
+2 SET BEXRDA=0
FOR
SET BEXRDA=$ORDER(^VEXHRX0(19080.1,BEXRDA))
IF 'BEXRDA
QUIT
Begin DoDot:1
+3 IF $PIECE($GET(^VEXHRX0(19080.1,BEXRDA,0)),U,9)
QUIT
+4 DO CR(BEXRDA)
End DoDot:1
+5 QUIT
+6 ;
MARK(BEXRDA) ;EP - mark entries as completed
+1 NEW BEXFDA,BEXIENS,BEXERR
+2 SET BEXIENS=BEXRDA_","
+3 SET BEXFDA(90350.1,BEXIENS,9)=1
+4 DO UPDATE^DIE("","BEXFDA","BEXIENS","BEXERR(1)")
+5 DO EOJCR
+6 QUIT
+7 ;
IDX ;EP - reindex all x ref upon entry into menu
+1 WRITE !!,"I need to update files, please stand by.."
+2 SET DIK="^VEXHRX0(19080.1,"
DO IXALL^DIK
+3 KILL DIK
+4 QUIT
+5 ;
DIE ;EP
+1 SET DIE="^VEXHRX0(19080.1,"
+2 SET BEXIDA=0
FOR
SET BEXIDA=$ORDER(^VEXHRX0(19080.1,"C",BEXIDA))
IF BEXIDA=""
QUIT
Begin DoDot:1
+3 SET BEXIIEN=0
FOR
SET BEXIIEN=$ORDER(^VEXHRX0(19080.1,"C",BEXIDA,BEXIIEN))
IF 'BEXIIEN
QUIT
Begin DoDot:2
+4 SET BEXIDT=$PIECE($GET(BEXIDA),".")
+5 IF $PIECE($GET(BEXIDA),".",2)'=0
QUIT
+6 SET BEXNIDT=BEXIDT_".12"
+7 SET BEXNIDT=+BEXNIDT
+8 SET BEXEIDT=$$FMTE^XLFDT(BEXNIDT)
+9 SET DA=BEXIIEN
SET DR="1///"_BEXEIDT
+10 DO ^DIE
+11 KILL DR,DA
End DoDot:2
End DoDot:1
+12 KILL DIE,BEXIDA,BEXNIDT,BEXIIEN
+13 QUIT
+14 ;
HDR ;EP
+1 SET BEXPKG="BEXR Audiocare Pharmacy Refill System"
+2 SET BEXLOC="Location: "_$PIECE($GET(^DIC(4,DUZ(2),0)),U)
+3 SET BEXTAB=(80-$LENGTH(BEXLOC))/2
+4 WRITE !,?(80-$LENGTH(BEXPKG))/2,BEXPKG
+5 WRITE !,?BEXTAB,BEXLOC
+6 QUIT
+7 ;
MED ;-- populate 90350.1 with med name in 11th piece
+1 NEW BEXDA
+2 SET BEXDA=0
FOR
SET BEXDA=$ORDER(^VEXHRX0(19080.1,BEXDA))
IF 'BEXDA
QUIT
Begin DoDot:1
+3 IF $PIECE($GET(^VEXHRX0(19080.1,BEXDA,0)),U,11)
QUIT
+4 NEW BEXRX,BEXRXI,BEXDRG
+5 SET BEXRX=$PIECE($GET(^VEXHRX0(19080.1,BEXDA,0)),U,3)
+6 IF 'BEXRX
QUIT
+7 SET BEXRXI=$ORDER(^PSRX("B",BEXRX,0))
+8 IF 'BEXRXI
QUIT
+9 SET BEXDRG=$PIECE($GET(^PSRX(BEXRXI,0)),U,6)
+10 IF 'BEXDRG
QUIT
+11 NEW BEXFDA,BEXIEN,BEXERR
+12 SET BEXIEN=BEXDA_","
+13 SET BEXFDA(90350.1,BEXIEN,11)=BEXDRG
+14 DO FILE^DIE("K","BEXFDA","BEXERR(1)")
End DoDot:1
+15 QUIT
+16 ;
