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

BEXRX.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ;cmi/anch/maw 9/17/2004 added PIMS53 and ADDCR subroutines for PIMS 5.3
  1. ;
  1. START D:'$D(PSOPAR) ^PSOLSET G:'$D(PSOPAR) END
  1. S (VEXRX,BEXRX)=1 ;cmi/maw 9/9/02 for auto ref
  1. W !!!?20,"Division: "_$P(^PS(59,PSOSITE,0),"^"),!!
  1. S PSOBBC1("FROM")="REFILL",PSOBBC("QFLG")=0,PSOBBC("DFLG")=0
  1. S PSOINST=000 I $D(^DD("SITE",1)) S PSOINST=^DD("SITE",1) ;maw 9/9/02
  1. S PSOFROM="REFILL" ;maw for release
  1. I '$D(^VEXHRX(19080,PSOINST)) S BEXANS="N" W !!?7,*7,"There are no telephone refills to process." G END
  1. D ASK^PSOBBC W:PSOBBC("QFLG")=1 !?7,*7,"No telephone refills were processed." G:PSOBBC("QFLG")=1 END
  1. BEX I $$CUT G END ;cmi/maw check for cutoff
  1. 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
  1. G:Y=0 END S BEXPTRX="" I Y=1 S BEXANS="Y"
  1. 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
  1. S (BEXCTR,VEXCTR)=0 ;cmi/maw 9/9/02 for sum lab
  1. BEX6 S PSOBBC("DFLG")="" ;maw added 3/9/2004 for reset of flag
  1. I BEXANS["Y",$G(BEXPTRX) D BEX5 ;MARK PROCESSED NODES
  1. D BEX3 G:BEXANS="N" END
  1. I $P(X,"-")'=PSOINST W !?7,*7,*7,*7,"Not from this institution.",! G BEX6
  1. S (PSOBBC("IRXN"),PSOBBC("OIRXN"))=$P(X,"-",2)
  1. S PSORX("PSOL",1)=PSOBBC("IRXN")_"," ;cmi/maw 9/9/02
  1. I $D(^PSRX(PSOBBC("IRXN"),0))']"" W !,*7,"Rx data is not on file!",! G BEX6
  1. I $P(^PSRX(PSOBBC("IRXN"),0),"^",15)=13 W !,*7,"Rx has already been deleted." G BEX6
  1. I $G(PSOBBC("DONE"))[PSOBBC("IRXN")_"," W !,*7,"Rx has already been entered." G BEX6
  1. K X,Y D:PSOBBC("QFLG") PROCESSX^PSOBBC
  1. 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
  1. ;D PROCESSX^PSOBBC ;maw 5/4/2006 added to print summary label for each
  1. ;I '$G(PSOSELSE) D PTC^PSOBBC I $G(PSOBBC("DFLG")) K PSOSELSE G BEX6
  1. K PSOSELSE D PROFILE^PSORX ;S X="PPPPDA1" X ^%ZOSF("TEST") I S X=$$PDA^PPPPDA1(PSODFN) W !! ;cmi/maw 9/9/02
  1. S PSOBBC("DONE")=PSOBBC("IRXN")_"," D REFILL^PSOBBC G BEX6
  1. Q
  1. 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).
  1. I '$D(^PSRX(+$P(BEXPTRX,"-",2),0)),^VEXHRX(19080,PSOINST,BEXPTRX)="" D BEX5,BEX12 G BEX3 ; SKIPS ERRONEOUS ENTRIES
  1. BEX4 I BEXANS["Y" G:^VEXHRX(19080,PSOINST,BEXPTRX)'="" BEX3 S X=PSOINST_"-"_$P(BEXPTRX,"-",2) ;SKIPS ENTRIES ALREADY PROCESSED AND FORMATS VARIABLE X
  1. BEX10 I BEXANS2["S",$D(^PSRX(+$P(BEXPTRX,"-",2),0)),PSOSITE'=$P(^PSRX(+$P(BEXPTRX,"-",2),2),"^",9) D BEX3
  1. Q
  1. ;LINES CALLED TO MARK PROCESSED NODES
  1. BEX5 S PSOINST=000 I $D(^DD("SITE",1)) S PSOINST=^DD("SITE",1) ;maw 9/9/02
  1. S ^VEXHRX(19080,PSOINST,BEXPTRX)=DT ;MARKS NODE AS PROCESSED
  1. I $D(PSOBBC("DFLG")),PSOBBC("DFLG")=1 D BEX12 ;FLAGS UNSUCCESSFUL ATTEMPTS TO REFILL.
  1. Q
  1. BEX12 S $P(^VEXHRX(19080,PSOINST,BEXPTRX),U,2)="NOT FILLED" W !!,*7,"REFILL WAS NOT PROCESSED! PLEASE TAKE APPROPRIATE ACTION."
  1. S PSOBBC("DFLG")="" ;maw added 3/9/2004 for reset if flag
  1. W ! S DIR("A")="Do you wish to continue processing",DIR(0)="Y" D ^DIR K DIR I Y'=1 S BEXANS="N" Q
  1. Q
  1. END ;
  1. D PROCESSX^PSOBBC
  1. K BEXRX,BEXPPL,PSORX ;cmi/maw 9/9/02 for auto ref
  1. K DIR,PSOBBC,PSOBBC1,BEXANS,BEXANS2,BEXPTRX,X,Y
  1. Q
  1. BEXALT ;Menu action entry point to alert user
  1. S BEXCNT=0,BEXPTRN=""
  1. I '$G(PSOINST) S PSOINST="000" I $D(^DD("SITE",1)) S PSOINST=^(1)
  1. G:'$D(^VEXHRX(19080,PSOINST)) BEXEND
  1. F S BEXPTRN=$O(^VEXHRX(19080,PSOINST,BEXPTRN)) Q:BEXPTRN="" D
  1. .I ^VEXHRX(19080,PSOINST,BEXPTRN)="" S BEXCNT=BEXCNT+1
  1. W:BEXCNT !!,*7,BEXCNT_" Telephone Refills To Process"
  1. BEXEND K BEXCNT,BEXPTRN
  1. Q
  1. ;
  1. CUT() ;check cutoff time and now
  1. S VSITEO=$O(^BEXHRXP("B",DUZ(2),0))
  1. I '$G(VSITEO) Q 0
  1. S VSITE=$P($G(^BEXHRXP(VSITEO,0)),U)
  1. I '$G(VSITE) Q 0
  1. S VCUT=$P($G(^BEXHRXP(VSITEO,0)),U,3)
  1. I '$G(VCUT) Q 0
  1. D NOW^%DTC
  1. I $E($P(%,".",2),1,4)>+$G(VCUT) D Q 1
  1. . W !,"Process time is past daily cut off time, refills will not be processed"
  1. Q 0
  1. ;
  1. CR(BEXVIEN) ;EP - add a chart request
  1. ;
  1. ;IHS/BJI/DAY - Patch 6
  1. ;This is called from the AC Xref on the BEX Transaction File
  1. ;Re-Direct this from BEXRX to the newer BEXRX7
  1. D CR^BEXRX7(BEXVIEN)
  1. Q BEXVIEN
  1. ;
  1. I $G(U)="" S U="^"
  1. S BEXPAT=$P($G(^VEXHRX0(19080.1,BEXVIEN,0)),U)
  1. I '$G(BEXPAT) Q ""
  1. S BEXTS=$P($G(^VEXHRX0(19080.1,BEXVIEN,0)),U,2)
  1. I '$G(DUZ(2)) S DUZ(2)=$P($G(^AUTTSITE(1,0)),U)
  1. S BEXPSITE=$O(^PS(59,"C",DUZ(2),0))
  1. I '$G(BEXPSITE) S DUZ(2)=$P($G(^AUTTSITE(1,0)),U)
  1. S BEXPSITE=$O(^PS(59,"C",DUZ(2),0))
  1. I '$G(BEXPSITE) Q ""
  1. S BEXVSITO=$O(^BEXHRXP("B",BEXPSITE,0))
  1. I '$G(BEXVSITO) Q ""
  1. S BEXVSITE=$P($G(^BEXHRXP(BEXVSITO,0)),U)
  1. I '$G(BEXVSITE) Q ""
  1. S BEXTSCA=$P($G(^BEXHRXP(BEXVSITO,0)),U,7)
  1. S BEXTSRA=$P($G(^BEXHRXP(BEXVSITO,0)),U,8)
  1. S BEXTSRP=$P($G(^BEXHRXP(BEXVSITO,0)),U,9)
  1. I '$G(BEXTS) S BEXTS=DT_".08"
  1. S BEXOTM=$E($P(BEXTS,".",2),1,4)
  1. I BEXOTM=0 Q ""
  1. I $L(BEXOTM)=1 S BEXOTM=BEXOTM_"000"
  1. I $L(BEXOTM)=2 S BEXOTM=BEXOTM_"00"
  1. I $L(BEXOTM)=3 S BEXOTM=BEXOTM_"0"
  1. S BEXTSP=$P(BEXTS,".")_"."_$S($G(BEXTSRP):BEXTSRP,1:2000)
  1. S BEXTSP=+BEXTSP
  1. S BEXTS=$P(BEXTS,".")_"."_$S($G(BEXTSRA):BEXTSRA,1:"08")
  1. S BEXTS=+BEXTS
  1. S BEXCLNA=$P($G(^BEXHRXP(BEXVSITO,0)),U,4)
  1. S BEXCLNB=$P($G(^BEXHRXP(BEXVSITO,0)),U,5)
  1. S BEXCUT=$P($G(^BEXHRXP(BEXVSITO,0)),U,3)
  1. S BEXREFO=$P($G(^BEXHRXP(BEXVSITO,0)),U,2)
  1. I '$G(BEXCLNA) Q ""
  1. I '$D(^DPT(BEXPAT,0)) Q ""
  1. S BEXCLNI=BEXCLNA
  1. S BEXPM=0
  1. I $G(BEXCUT),$G(BEXCLNB) D
  1. . I (BEXOTM>BEXCUT)!(BEXOTM<BEXTSCA) S BEXCLNI=BEXCLNB,BEXTS=BEXTSP,BEXPM=1
  1. I 'BEXCLNI S BEXCLNI=BEXCLNA
  1. I 'BEXCLNI Q ""
  1. I $G(BEXREFO),$P($G(^VEXHRX0(19080.1,BEXVIEN,0)),U,5)'="REFILLABLE" Q ""
  1. I $$PIMS53 D ADDCR(BEXCLNI,BEXPAT,BEXTS,+$G(BEXPM)),ADDDPT(BEXCLNI,BEXPAT,BEXTS) Q "1^Chart Request Successful" ;for PIMS 5.3
  1. I $$LKPT(BEXPAT,BEXCLNI,BEXTS) Q ""
  1. I '$D(^SC(BEXCLNI,"S",BEXTS,0)) D
  1. . S ^SC(BEXCLNI,"S",BEXTS,0)=BEXTS
  1. I '$D(^SC(BEXCLNI,"S",BEXTS,1,0)) D
  1. . S ^SC(BEXCLNI,"S",BEXTS,1,0)="^44.003PA^^"
  1. S BEXNXT=$$GNXT(BEXCLNI,BEXTS)
  1. S ^SC(BEXCLNI,"S",BEXTS,1,BEXNXT,0)=BEXPAT_U_U_U_"PHARMACY CHART REQUEST (TA)"
  1. S ^SC(BEXCLNI,"S",BEXTS,1,BEXNXT,"C")=BEXTS
  1. I '$D(^DPT(BEXPAT,"S",0)) D
  1. . S ^DPT(BEXPAT,"S",0)="^2.98^^"
  1. S BEXAPTP=$O(^SD(409.1,"B","COMPUTER GENERATED",0))
  1. S ^DPT(BEXPAT,"S",BEXTS,0)=BEXCLNI_U_U_U_U_U_U_U_U_U_U_U_U_U_U_U_$G(BEXAPTP)
  1. D RS(BEXPAT,BEXCLNI)
  1. Q "1^Chart Request Successful"
  1. ;
  1. PIMS53() ;-- check for pims 5.3
  1. N BEXPIMS
  1. S BEXPIMS=$O(^DIC(9.4,"C","PIMS",0))
  1. I '$G(BEXPIMS) Q 0
  1. I $G(^DIC(9.4,BEXPIMS,"VERSION"))>5.29 Q 1
  1. Q 0
  1. ;
  1. ADDDPT(CLN,PAT,TS) ;-- add the appointment to the patient file
  1. N BEXIENS,BEXERR,BEXFDA,BEXDATE,BEXNOW,BEXPATE,BEXAPTP
  1. S BEXAPTP=$O(^SD(409.1,"B","COMPUTER GENERATED",0))
  1. S BEXIENS=""
  1. S BEXIENS(1)=PAT
  1. S BEXIENS(2)=TS
  1. S BEXPATE=$P($G(^DPT(PAT,0)),U)
  1. S BEXFDA(2,BEXIENS(1)_",",.01)=BEXPATE
  1. S BEXFDA(2.98,"?+2,"_BEXIENS(1)_",",.01)=CLN
  1. S BEXFDA(2.98,"?+2,"_BEXIENS(1)_",",9.5)=BEXAPTP
  1. D UPDATE^DIE("","BEXFDA","BEXIENS","BEXERR(1)")
  1. Q:$D(BEXERR)
  1. Q
  1. ;
  1. ADDCR(CLN,PAT,TS,PM) ;-- add a chart request and print a routing slip for pims 5.3
  1. Q:$D(^SC(CLN,"C",TS,1,PAT)) ;1/11/05 cmi/maw don't print if already printed for this time
  1. N BEXIENS,BEXERR,BEXFDA,BEXDATE,BEXNOW,BEXCLNE,BEXDEV
  1. S BEXIENS=""
  1. S BEXIENS(1)=CLN
  1. S BEXIENS(2)=TS
  1. S BEXIENS(3)=PAT
  1. S BEXCLNE=$P($G(^SC(CLN,0)),U)
  1. S BEXFDA(44,"?1,",.01)=BEXCLNE
  1. S BEXFDA(44.006,"?+2,?1,",.01)=TS
  1. S BEXFDA(44.007,"?+3,?+2,?1,",.01)=PAT
  1. S BEXFDA(44.007,"?+3,?+2,?1,",9999999.01)=TS
  1. S BEXFDA(44.007,"?+3,?+2,?1,",9999999.02)=$G(DUZ)
  1. S BEXFDA(44.007,"?+3,?+2,?1,",9999999.03)="Audiocare Telephone Refill"
  1. D UPDATE^DIE("","BEXFDA","BEXIENS","BEXERR(1)")
  1. Q:$D(BEXERR)
  1. I $G(PM) D
  1. . S BEXDEV=$$GET1^DIQ(90350.2,BEXVSITO,2) ;maw for pm clinic printer
  1. I $G(BEXDEV)="" S BEXDEV=$$GET1^DIQ(90350.2,BEXVSITO,1) ;maw new print parm
  1. Q:BEXDEV=""
  1. S DGQUIET=1 ;for routing slip
  1. D WISD^BSDROUT(PAT,$P(TS,"."),"CR",BEXDEV)
  1. Q
  1. ;
  1. RS(DFN,CI) ;-- print a routine slip
  1. Q:'$P($G(^BEXHRXP(BEXVSITO,0)),U,6) ;auto print
  1. S VAR="DIV^ORDER^SDX^DFN^SDREP^SDSTART^SDZHS^ASDLONG^SDZSC^SDZCV^SDPR",DGPGM="EN1^SDROUT1" ;for routing slips
  1. ;S BEXDEV=$$VAL^XBDIQ1(40.8,$$DIV^ASDUT,9999999.11) ;maw old
  1. S BEXDEV=$$GET1^DIQ(90350.2,BEXVSITO,1) ;maw new print parm
  1. I $G(BEXDEV)="" Q
  1. S DIV=$P($G(^SC(CI,0)),U,15) ;for routing slip
  1. S (SDZZWI,SDZCV,DGUTQND)=1
  1. S IOP=BEXDEV,POP=0,%ZIS="Q" D ^%ZIS Q:$G(POP)
  1. ;D ^%ZIS ;for testing
  1. ;D EN^XBNEW("EN1^SDROUT1","SD*;DFN;DIV;IO*")
  1. D EN^XBNEW("Q1^DGUTQ","SD*;DFN;DG*;DIV;VAR;IO*")
  1. Q
  1. ;
  1. LKPT(PT,CI,TM) ;-- check to see if patient has chart request already
  1. K BEXCRE
  1. S BEXIEN=0 F S BEXIEN=$O(^SC(CI,"S",TM,1,BEXIEN)) Q:'BEXIEN D
  1. . I $P($G(^SC(CI,"S",TM,1,BEXIEN,0)),U)=PT S BEXCRE=1 Q
  1. Q $G(BEXCRE)
  1. ;
  1. GNXT(CI,TM) ;-- get next ien for clinic
  1. K BEXNXT
  1. S BEXIEN=0 F S BEXIEN=$O(^SC(CI,"S",TM,1,BEXIEN)) Q:'BEXIEN D
  1. . S BEXNXT=BEXIEN
  1. Q $G(BEXNXT)+1
  1. ;
  1. EOJCR ;-- kill vars
  1. D EN^XBVK("SD")
  1. D EN^XBVK("BEX")
  1. D EN^XBVK("VSIT")
  1. D EN^XBVK("CLN")
  1. K OTM,PAT,TS,TSM,TSCA,TSCP
  1. Q
  1. ;
  1. TSK ;EP - loop the transactiopn file and request charts
  1. D ^XBKVAR
  1. S BEXRDA=0 F S BEXRDA=$O(^VEXHRX0(19080.1,BEXRDA)) Q:'BEXRDA D
  1. . Q:$P($G(^VEXHRX0(19080.1,BEXRDA,0)),U,9)
  1. . S BEXCR=$$CR(BEXRDA)
  1. . S DIE="^VEXHRX0(19080.1,",DA=BEXRDA
  1. . S DR="9///Y"
  1. . D ^DIE
  1. . K DIE
  1. D EOJCR
  1. Q
  1. ;
  1. IDX ;EP - reindex all x ref upon entry into menu
  1. W !!,"I need to update files, please stand by.."
  1. S DIK="^VEXHRX0(19080.1," D IXALL^DIK
  1. K DIK
  1. Q
  1. ;
  1. DIE ;EP
  1. S DIE="^VEXHRX0(19080.1,"
  1. S BEXIDA=0 F S BEXIDA=$O(^VEXHRX0(19080.1,"C",BEXIDA)) Q:BEXIDA="" D
  1. . S BEXIIEN=0 F S BEXIIEN=$O(^VEXHRX0(19080.1,"C",BEXIDA,BEXIIEN)) Q:'BEXIIEN D
  1. .. S BEXIDT=$P($G(BEXIDA),".")
  1. .. Q:$P($G(BEXIDA),".",2)'=0
  1. .. S BEXNIDT=BEXIDT_".12"
  1. .. S BEXNIDT=+BEXNIDT
  1. .. S BEXEIDT=$$FMTE^XLFDT(BEXNIDT)
  1. .. S DA=BEXIIEN,DR="1///"_BEXEIDT
  1. .. D ^DIE
  1. .. K DR,DA
  1. K DIE,BEXIDA,BEXNIDT,BEXIIEN
  1. Q
  1. ;
  1. HDR ;EP - header
  1. S BEXPKG="BEXR Audiocare Pharmacy Refill System"
  1. S BEXLOC="Location: "_$P($G(^DIC(4,DUZ(2),0)),U)
  1. S BEXTAB=(80-$L(BEXLOC))/2
  1. W !,?(80-$L(BEXPKG))/2,BEXPKG
  1. W !,?BEXTAB,BEXLOC
  1. Q
  1. ;