BEXRX ; cmi/anch/maw - BEX Audiocare Refill Driver ; 04 Dec 2015 8:04 AM
;;1.0;BEX TELEPHONE REFILL SYSTEM;**1,2,4,6**;DEC 01, 2009;Build 7
;
;cmi/anch/maw 9/17/2004 added PIMS53 and ADDCR subroutines for PIMS 5.3
;
START D:'$D(PSOPAR) ^PSOLSET G:'$D(PSOPAR) END
S (VEXRX,BEXRX)=1 ;cmi/maw 9/9/02 for auto ref
W !!!?20,"Division: "_$P(^PS(59,PSOSITE,0),"^"),!!
S PSOBBC1("FROM")="REFILL",PSOBBC("QFLG")=0,PSOBBC("DFLG")=0
S PSOINST=000 I $D(^DD("SITE",1)) S PSOINST=^DD("SITE",1) ;maw 9/9/02
S PSOFROM="REFILL" ;maw for release
I '$D(^VEXHRX(19080,PSOINST)) S BEXANS="N" W !!?7,*7,"There are no telephone refills to process." G END
D ASK^PSOBBC W:PSOBBC("QFLG")=1 !?7,*7,"No telephone refills were processed." G:PSOBBC("QFLG")=1 END
BEX I $$CUT G END ;cmi/maw check for cutoff
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"
I BEXANS["Y" S DIR("B")="YES",DIR("A")="Process telephone refills for all divisions",DIR(0)="Y" D ^DIR K DIR S BEXANS2="S" S:Y=1 BEXANS2="M" I $G(DIRUT) S BEXANS="N" G END
S (BEXCTR,VEXCTR)=0 ;cmi/maw 9/9/02 for sum lab
BEX6 S PSOBBC("DFLG")="" ;maw added 3/9/2004 for reset of flag
I BEXANS["Y",$G(BEXPTRX) D BEX5 ;MARK PROCESSED NODES
D BEX3 G:BEXANS="N" END
I $P(X,"-")'=PSOINST W !?7,*7,*7,*7,"Not from this institution.",! G BEX6
S (PSOBBC("IRXN"),PSOBBC("OIRXN"))=$P(X,"-",2)
S PSORX("PSOL",1)=PSOBBC("IRXN")_"," ;cmi/maw 9/9/02
I $D(^PSRX(PSOBBC("IRXN"),0))']"" W !,*7,"Rx data is not on file!",! G BEX6
I $P(^PSRX(PSOBBC("IRXN"),0),"^",15)=13 W !,*7,"Rx has already been deleted." G BEX6
I $G(PSOBBC("DONE"))[PSOBBC("IRXN")_"," W !,*7,"Rx has already been entered." G BEX6
K X,Y D:PSOBBC("QFLG") PROCESSX^PSOBBC
S PSOSELSE=0 I $G(PSODFN)'=$P(^PSRX(PSOBBC("IRXN"),0),"^",2) S PSOSELSE=1 D PT^PSOBBC I $G(PSOBBC("DFLG")) K PSOSELSE G BEX6
;D PROCESSX^PSOBBC ;maw 5/4/2006 added to print summary label for each
;I '$G(PSOSELSE) D PTC^PSOBBC I $G(PSOBBC("DFLG")) K PSOSELSE G BEX6
K PSOSELSE D PROFILE^PSORX ;S X="PPPPDA1" X ^%ZOSF("TEST") I S X=$$PDA^PPPPDA1(PSODFN) W !! ;cmi/maw 9/9/02
S PSOBBC("DONE")=PSOBBC("IRXN")_"," D REFILL^PSOBBC G BEX6
Q
BEX3 K PSOBBC("IRXN") S BEXPTRX=$O(^VEXHRX(19080,PSOINST,BEXPTRX)) I BEXPTRX="" S BEXANS="N" Q ;PSOINST REPRESENTS THE INSTITUTION SITE NUMBER (623 HERE).
I '$D(^PSRX(+$P(BEXPTRX,"-",2),0)),^VEXHRX(19080,PSOINST,BEXPTRX)="" D BEX5,BEX12 G BEX3 ; SKIPS ERRONEOUS ENTRIES
BEX4 I BEXANS["Y" G:^VEXHRX(19080,PSOINST,BEXPTRX)'="" BEX3 S X=PSOINST_"-"_$P(BEXPTRX,"-",2) ;SKIPS ENTRIES ALREADY PROCESSED AND FORMATS VARIABLE X
BEX10 I BEXANS2["S",$D(^PSRX(+$P(BEXPTRX,"-",2),0)),PSOSITE'=$P(^PSRX(+$P(BEXPTRX,"-",2),2),"^",9) D BEX3
Q
;LINES CALLED TO MARK PROCESSED NODES
BEX5 S PSOINST=000 I $D(^DD("SITE",1)) S PSOINST=^DD("SITE",1) ;maw 9/9/02
S ^VEXHRX(19080,PSOINST,BEXPTRX)=DT ;MARKS NODE AS PROCESSED
I $D(PSOBBC("DFLG")),PSOBBC("DFLG")=1 D BEX12 ;FLAGS UNSUCCESSFUL ATTEMPTS TO REFILL.
Q
BEX12 S $P(^VEXHRX(19080,PSOINST,BEXPTRX),U,2)="NOT FILLED" W !!,*7,"REFILL WAS NOT PROCESSED! PLEASE TAKE APPROPRIATE ACTION."
S PSOBBC("DFLG")="" ;maw added 3/9/2004 for reset if flag
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 ;cmi/maw 9/9/02 for auto ref
K DIR,PSOBBC,PSOBBC1,BEXANS,BEXANS2,BEXPTRX,X,Y
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 ^VEXHRX(19080,PSOINST,BEXPTRN)="" S BEXCNT=BEXCNT+1
W:BEXCNT !!,*7,BEXCNT_" Telephone Refills To Process"
BEXEND K BEXCNT,BEXPTRN
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
;
;IHS/BJI/DAY - Patch 6
;This is called from the AC Xref on the BEX Transaction File
;Re-Direct this from BEXRX to the newer BEXRX7
D CR^BEXRX7(BEXVIEN)
Q BEXVIEN
;
I $G(U)="" S U="^"
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)
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))
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 ""
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) 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 ""
I $G(BEXREFO),$P($G(^VEXHRX0(19080.1,BEXVIEN,0)),U,5)'="REFILLABLE" Q ""
I $$PIMS53 D ADDCR(BEXCLNI,BEXPAT,BEXTS,+$G(BEXPM)),ADDDPT(BEXCLNI,BEXPAT,BEXTS) Q "1^Chart Request Successful" ;for PIMS 5.3
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)
Q "1^Chart Request Successful"
;
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
;
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,BEXIENS(1)_",",.01)=BEXPATE
S BEXFDA(2.98,"?+2,"_BEXIENS(1)_",",.01)=CLN
S BEXFDA(2.98,"?+2,"_BEXIENS(1)_",",9.5)=BEXAPTP
D UPDATE^DIE("","BEXFDA","BEXIENS","BEXERR(1)")
Q:$D(BEXERR)
Q
;
ADDCR(CLN,PAT,TS,PM) ;-- add a chart request and print a routing slip for pims 5.3
Q:$D(^SC(CLN,"C",TS,1,PAT)) ;1/11/05 cmi/maw don't print if already printed for this time
N BEXIENS,BEXERR,BEXFDA,BEXDATE,BEXNOW,BEXCLNE,BEXDEV
S BEXIENS=""
S BEXIENS(1)=CLN
S BEXIENS(2)=TS
S BEXIENS(3)=PAT
S BEXCLNE=$P($G(^SC(CLN,0)),U)
S BEXFDA(44,"?1,",.01)=BEXCLNE
S BEXFDA(44.006,"?+2,?1,",.01)=TS
S BEXFDA(44.007,"?+3,?+2,?1,",.01)=PAT
S BEXFDA(44.007,"?+3,?+2,?1,",9999999.01)=TS
S BEXFDA(44.007,"?+3,?+2,?1,",9999999.02)=$G(DUZ)
S BEXFDA(44.007,"?+3,?+2,?1,",9999999.03)="Audiocare Telephone Refill"
D UPDATE^DIE("","BEXFDA","BEXIENS","BEXERR(1)")
Q:$D(BEXERR)
I $G(PM) D
. S BEXDEV=$$GET1^DIQ(90350.2,BEXVSITO,2) ;maw for pm clinic printer
I $G(BEXDEV)="" S BEXDEV=$$GET1^DIQ(90350.2,BEXVSITO,1) ;maw new print parm
Q:BEXDEV=""
S DGQUIET=1 ;for routing slip
D WISD^BSDROUT(PAT,$P(TS,"."),"CR",BEXDEV)
Q
;
RS(DFN,CI) ;-- print a routine slip
Q:'$P($G(^BEXHRXP(BEXVSITO,0)),U,6) ;auto print
S VAR="DIV^ORDER^SDX^DFN^SDREP^SDSTART^SDZHS^ASDLONG^SDZSC^SDZCV^SDPR",DGPGM="EN1^SDROUT1" ;for routing slips
;S BEXDEV=$$VAL^XBDIQ1(40.8,$$DIV^ASDUT,9999999.11) ;maw old
S BEXDEV=$$GET1^DIQ(90350.2,BEXVSITO,1) ;maw new print parm
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("EN1^SDROUT1","SD*;DFN;DIV;IO*")
D EN^XBNEW("Q1^DGUTQ","SD*;DFN;DG*;DIV;VAR;IO*")
Q
;
LKPT(PT,CI,TM) ;-- check to see if patient has chart request 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 the transactiopn 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)
. S BEXCR=$$CR(BEXRDA)
. S DIE="^VEXHRX0(19080.1,",DA=BEXRDA
. S DR="9///Y"
. D ^DIE
. K DIE
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 - header
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
;
BEXRX ; cmi/anch/maw - BEX Audiocare Refill Driver ; 04 Dec 2015 8:04 AM
+1 ;;1.0;BEX TELEPHONE REFILL SYSTEM;**1,2,4,6**;DEC 01, 2009;Build 7
+2 ;
+3 ;cmi/anch/maw 9/17/2004 added PIMS53 and ADDCR subroutines for PIMS 5.3
+4 ;
START IF '$DATA(PSOPAR)
DO ^PSOLSET
IF '$DATA(PSOPAR)
GOTO END
+1 ;cmi/maw 9/9/02 for auto ref
SET (VEXRX,BEXRX)=1
+2 WRITE !!!?20,"Division: "_$PIECE(^PS(59,PSOSITE,0),"^"),!!
+3 SET PSOBBC1("FROM")="REFILL"
SET PSOBBC("QFLG")=0
SET PSOBBC("DFLG")=0
+4 ;maw 9/9/02
SET PSOINST=000
IF $DATA(^DD("SITE",1))
SET PSOINST=^DD("SITE",1)
+5 ;maw for release
SET PSOFROM="REFILL"
+6 IF '$DATA(^VEXHRX(19080,PSOINST))
SET BEXANS="N"
WRITE !!?7,*7,"There are no telephone refills to process."
GOTO END
+7 DO ASK^PSOBBC
IF PSOBBC("QFLG")=1
WRITE !?7,*7,"No telephone refills were processed."
IF PSOBBC("QFLG")=1
GOTO END
BEX ;cmi/maw check for cutoff
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 IF BEXANS["Y"
SET DIR("B")="YES"
SET DIR("A")="Process telephone refills for all divisions"
SET DIR(0)="Y"
DO ^DIR
KILL DIR
SET BEXANS2="S"
IF Y=1
SET BEXANS2="M"
IF $GET(DIRUT)
SET BEXANS="N"
GOTO END
+4 ;cmi/maw 9/9/02 for sum lab
SET (BEXCTR,VEXCTR)=0
BEX6 ;maw added 3/9/2004 for reset of flag
SET PSOBBC("DFLG")=""
+1 ;MARK PROCESSED NODES
IF BEXANS["Y"
IF $GET(BEXPTRX)
DO BEX5
+2 DO BEX3
IF BEXANS="N"
GOTO END
+3 IF $PIECE(X,"-")'=PSOINST
WRITE !?7,*7,*7,*7,"Not from this institution.",!
GOTO BEX6
+4 SET (PSOBBC("IRXN"),PSOBBC("OIRXN"))=$PIECE(X,"-",2)
+5 ;cmi/maw 9/9/02
SET PSORX("PSOL",1)=PSOBBC("IRXN")_","
+6 IF $DATA(^PSRX(PSOBBC("IRXN"),0))']""
WRITE !,*7,"Rx data is not on file!",!
GOTO BEX6
+7 IF $PIECE(^PSRX(PSOBBC("IRXN"),0),"^",15)=13
WRITE !,*7,"Rx has already been deleted."
GOTO BEX6
+8 IF $GET(PSOBBC("DONE"))[PSOBBC("IRXN")_","
WRITE !,*7,"Rx has already been entered."
GOTO BEX6
+9 KILL X,Y
IF PSOBBC("QFLG")
DO PROCESSX^PSOBBC
+10 SET PSOSELSE=0
IF $GET(PSODFN)'=$PIECE(^PSRX(PSOBBC("IRXN"),0),"^",2)
SET PSOSELSE=1
DO PT^PSOBBC
IF $GET(PSOBBC("DFLG"))
KILL PSOSELSE
GOTO BEX6
+11 ;D PROCESSX^PSOBBC ;maw 5/4/2006 added to print summary label for each
+12 ;I '$G(PSOSELSE) D PTC^PSOBBC I $G(PSOBBC("DFLG")) K PSOSELSE G BEX6
+13 ;S X="PPPPDA1" X ^%ZOSF("TEST") I S X=$$PDA^PPPPDA1(PSODFN) W !! ;cmi/maw 9/9/02
KILL PSOSELSE
DO PROFILE^PSORX
+14 SET PSOBBC("DONE")=PSOBBC("IRXN")_","
DO REFILL^PSOBBC
GOTO BEX6
+15 QUIT
BEX3 ;PSOINST REPRESENTS THE INSTITUTION SITE NUMBER (623 HERE).
KILL PSOBBC("IRXN")
SET BEXPTRX=$ORDER(^VEXHRX(19080,PSOINST,BEXPTRX))
IF BEXPTRX=""
SET BEXANS="N"
QUIT
+1 ; SKIPS ERRONEOUS ENTRIES
IF '$DATA(^PSRX(+$PIECE(BEXPTRX,"-",2),0))
IF ^VEXHRX(19080,PSOINST,BEXPTRX)=""
DO BEX5
DO BEX12
GOTO BEX3
BEX4 ;SKIPS ENTRIES ALREADY PROCESSED AND FORMATS VARIABLE X
IF BEXANS["Y"
IF ^VEXHRX(19080,PSOINST,BEXPTRX)'=""
GOTO BEX3
SET X=PSOINST_"-"_$PIECE(BEXPTRX,"-",2)
BEX10 IF BEXANS2["S"
IF $DATA(^PSRX(+$PIECE(BEXPTRX,"-",2),0))
IF PSOSITE'=$PIECE(^PSRX(+$PIECE(BEXPTRX,"-",2),2),"^",9)
DO BEX3
+1 QUIT
+2 ;LINES CALLED TO MARK PROCESSED NODES
BEX5 ;maw 9/9/02
SET PSOINST=000
IF $DATA(^DD("SITE",1))
SET PSOINST=^DD("SITE",1)
+1 ;MARKS NODE AS PROCESSED
SET ^VEXHRX(19080,PSOINST,BEXPTRX)=DT
+2 ;FLAGS UNSUCCESSFUL ATTEMPTS TO REFILL.
IF $DATA(PSOBBC("DFLG"))
IF PSOBBC("DFLG")=1
DO BEX12
+3 QUIT
BEX12 SET $PIECE(^VEXHRX(19080,PSOINST,BEXPTRX),U,2)="NOT FILLED"
WRITE !!,*7,"REFILL WAS NOT PROCESSED! PLEASE TAKE APPROPRIATE ACTION."
+1 ;maw added 3/9/2004 for reset if flag
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 ;
+1 DO PROCESSX^PSOBBC
+2 ;cmi/maw 9/9/02 for auto ref
KILL BEXRX,BEXPPL,PSORX
+3 KILL DIR,PSOBBC,PSOBBC1,BEXANS,BEXANS2,BEXPTRX,X,Y
+4 QUIT
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 ^VEXHRX(19080,PSOINST,BEXPTRN)=""
SET BEXCNT=BEXCNT+1
End DoDot:1
+6 IF BEXCNT
WRITE !!,*7,BEXCNT_" Telephone Refills To Process"
BEXEND KILL BEXCNT,BEXPTRN
+1 QUIT
+2 ;
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 ;
+2 ;IHS/BJI/DAY - Patch 6
+3 ;This is called from the AC Xref on the BEX Transaction File
+4 ;Re-Direct this from BEXRX to the newer BEXRX7
+5 DO CR^BEXRX7(BEXVIEN)
+6 QUIT BEXVIEN
+7 ;
+8 IF $GET(U)=""
SET U="^"
+9 SET BEXPAT=$PIECE($GET(^VEXHRX0(19080.1,BEXVIEN,0)),U)
+10 IF '$GET(BEXPAT)
QUIT ""
+11 SET BEXTS=$PIECE($GET(^VEXHRX0(19080.1,BEXVIEN,0)),U,2)
+12 IF '$GET(DUZ(2))
SET DUZ(2)=$PIECE($GET(^AUTTSITE(1,0)),U)
+13 SET BEXPSITE=$ORDER(^PS(59,"C",DUZ(2),0))
+14 IF '$GET(BEXPSITE)
SET DUZ(2)=$PIECE($GET(^AUTTSITE(1,0)),U)
+15 SET BEXPSITE=$ORDER(^PS(59,"C",DUZ(2),0))
+16 IF '$GET(BEXPSITE)
QUIT ""
+17 SET BEXVSITO=$ORDER(^BEXHRXP("B",BEXPSITE,0))
+18 IF '$GET(BEXVSITO)
QUIT ""
+19 SET BEXVSITE=$PIECE($GET(^BEXHRXP(BEXVSITO,0)),U)
+20 IF '$GET(BEXVSITE)
QUIT ""
+21 SET BEXTSCA=$PIECE($GET(^BEXHRXP(BEXVSITO,0)),U,7)
+22 SET BEXTSRA=$PIECE($GET(^BEXHRXP(BEXVSITO,0)),U,8)
+23 SET BEXTSRP=$PIECE($GET(^BEXHRXP(BEXVSITO,0)),U,9)
+24 IF '$GET(BEXTS)
SET BEXTS=DT_".08"
+25 SET BEXOTM=$EXTRACT($PIECE(BEXTS,".",2),1,4)
+26 IF BEXOTM=0
QUIT ""
+27 IF $LENGTH(BEXOTM)=1
SET BEXOTM=BEXOTM_"000"
+28 IF $LENGTH(BEXOTM)=2
SET BEXOTM=BEXOTM_"00"
+29 IF $LENGTH(BEXOTM)=3
SET BEXOTM=BEXOTM_"0"
+30 SET BEXTSP=$PIECE(BEXTS,".")_"."_$SELECT($GET(BEXTSRP):BEXTSRP,1:2000)
+31 SET BEXTSP=+BEXTSP
+32 SET BEXTS=$PIECE(BEXTS,".")_"."_$SELECT($GET(BEXTSRA):BEXTSRA,1:"08")
+33 SET BEXTS=+BEXTS
+34 SET BEXCLNA=$PIECE($GET(^BEXHRXP(BEXVSITO,0)),U,4)
+35 SET BEXCLNB=$PIECE($GET(^BEXHRXP(BEXVSITO,0)),U,5)
+36 SET BEXCUT=$PIECE($GET(^BEXHRXP(BEXVSITO,0)),U,3)
+37 SET BEXREFO=$PIECE($GET(^BEXHRXP(BEXVSITO,0)),U,2)
+38 IF '$GET(BEXCLNA)
QUIT ""
+39 IF '$DATA(^DPT(BEXPAT,0))
QUIT ""
+40 SET BEXCLNI=BEXCLNA
+41 SET BEXPM=0
+42 IF $GET(BEXCUT)
IF $GET(BEXCLNB)
Begin DoDot:1
+43 IF (BEXOTM>BEXCUT)!(BEXOTM<BEXTSCA)
SET BEXCLNI=BEXCLNB
SET BEXTS=BEXTSP
SET BEXPM=1
End DoDot:1
+44 IF 'BEXCLNI
SET BEXCLNI=BEXCLNA
+45 IF 'BEXCLNI
QUIT ""
+46 IF $GET(BEXREFO)
IF $PIECE($GET(^VEXHRX0(19080.1,BEXVIEN,0)),U,5)'="REFILLABLE"
QUIT ""
+47 ;for PIMS 5.3
IF $$PIMS53
DO ADDCR(BEXCLNI,BEXPAT,BEXTS,+$GET(BEXPM))
DO ADDDPT(BEXCLNI,BEXPAT,BEXTS)
QUIT "1^Chart Request Successful"
+48 IF $$LKPT(BEXPAT,BEXCLNI,BEXTS)
QUIT ""
+49 IF '$DATA(^SC(BEXCLNI,"S",BEXTS,0))
Begin DoDot:1
+50 SET ^SC(BEXCLNI,"S",BEXTS,0)=BEXTS
End DoDot:1
+51 IF '$DATA(^SC(BEXCLNI,"S",BEXTS,1,0))
Begin DoDot:1
+52 SET ^SC(BEXCLNI,"S",BEXTS,1,0)="^44.003PA^^"
End DoDot:1
+53 SET BEXNXT=$$GNXT(BEXCLNI,BEXTS)
+54 SET ^SC(BEXCLNI,"S",BEXTS,1,BEXNXT,0)=BEXPAT_U_U_U_"PHARMACY CHART REQUEST (TA)"
+55 SET ^SC(BEXCLNI,"S",BEXTS,1,BEXNXT,"C")=BEXTS
+56 IF '$DATA(^DPT(BEXPAT,"S",0))
Begin DoDot:1
+57 SET ^DPT(BEXPAT,"S",0)="^2.98^^"
End DoDot:1
+58 SET BEXAPTP=$ORDER(^SD(409.1,"B","COMPUTER GENERATED",0))
+59 SET ^DPT(BEXPAT,"S",BEXTS,0)=BEXCLNI_U_U_U_U_U_U_U_U_U_U_U_U_U_U_U_$GET(BEXAPTP)
+60 DO RS(BEXPAT,BEXCLNI)
+61 QUIT "1^Chart Request Successful"
+62 ;
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 ;
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,BEXIENS(1)_",",.01)=BEXPATE
+8 SET BEXFDA(2.98,"?+2,"_BEXIENS(1)_",",.01)=CLN
+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 ;
ADDCR(CLN,PAT,TS,PM) ;-- add a chart request and print a routing slip for pims 5.3
+1 ;1/11/05 cmi/maw don't print if already printed for this time
IF $DATA(^SC(CLN,"C",TS,1,PAT))
QUIT
+2 NEW BEXIENS,BEXERR,BEXFDA,BEXDATE,BEXNOW,BEXCLNE,BEXDEV
+3 SET BEXIENS=""
+4 SET BEXIENS(1)=CLN
+5 SET BEXIENS(2)=TS
+6 SET BEXIENS(3)=PAT
+7 SET BEXCLNE=$PIECE($GET(^SC(CLN,0)),U)
+8 SET BEXFDA(44,"?1,",.01)=BEXCLNE
+9 SET BEXFDA(44.006,"?+2,?1,",.01)=TS
+10 SET BEXFDA(44.007,"?+3,?+2,?1,",.01)=PAT
+11 SET BEXFDA(44.007,"?+3,?+2,?1,",9999999.01)=TS
+12 SET BEXFDA(44.007,"?+3,?+2,?1,",9999999.02)=$GET(DUZ)
+13 SET BEXFDA(44.007,"?+3,?+2,?1,",9999999.03)="Audiocare Telephone Refill"
+14 DO UPDATE^DIE("","BEXFDA","BEXIENS","BEXERR(1)")
+15 IF $DATA(BEXERR)
QUIT
+16 IF $GET(PM)
Begin DoDot:1
+17 ;maw for pm clinic printer
SET BEXDEV=$$GET1^DIQ(90350.2,BEXVSITO,2)
End DoDot:1
+18 ;maw new print parm
IF $GET(BEXDEV)=""
SET BEXDEV=$$GET1^DIQ(90350.2,BEXVSITO,1)
+19 IF BEXDEV=""
QUIT
+20 ;for routing slip
SET DGQUIET=1
+21 DO WISD^BSDROUT(PAT,$PIECE(TS,"."),"CR",BEXDEV)
+22 QUIT
+23 ;
RS(DFN,CI) ;-- print a routine slip
+1 ;auto print
IF '$PIECE($GET(^BEXHRXP(BEXVSITO,0)),U,6)
QUIT
+2 ;for routing slips
SET VAR="DIV^ORDER^SDX^DFN^SDREP^SDSTART^SDZHS^ASDLONG^SDZSC^SDZCV^SDPR"
SET DGPGM="EN1^SDROUT1"
+3 ;S BEXDEV=$$VAL^XBDIQ1(40.8,$$DIV^ASDUT,9999999.11) ;maw old
+4 ;maw new print parm
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 ;D EN^XBNEW("EN1^SDROUT1","SD*;DFN;DIV;IO*")
+11 DO EN^XBNEW("Q1^DGUTQ","SD*;DFN;DG*;DIV;VAR;IO*")
+12 QUIT
+13 ;
LKPT(PT,CI,TM) ;-- check to see if patient has chart request 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 the transactiopn 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 SET BEXCR=$$CR(BEXRDA)
+5 SET DIE="^VEXHRX0(19080.1,"
SET DA=BEXRDA
+6 SET DR="9///Y"
+7 DO ^DIE
+8 KILL DIE
End DoDot:1
+9 DO EOJCR
+10 QUIT
+11 ;
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 - header
+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 ;
