- 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 ;