source: WorldVistAEHR/trunk/r/E_CLAIMS_MGMT_ENGINE-BPS/BPS01P5C.m@ 724

Last change on this file since 724 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.2 KB
Line 
1BPS01P5C ;ALB/SS - BPS*1.0*5 POST INSTALL ROUTINE ;14-NOV-06
2 ;;1.0;E CLAIMS MGMT ENGINE;**5**;JUN 2004;Build 45
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 Q
5 ;/*
6 ;Get ePharmacy ien by:
7 ; BPSDT - date,
8 ; BPSRXIEN - RX ien and
9 ; BPSREF - refil number
10 ;by using BPS LOG file, then BPS TRANSACTION file and then PRESCRIPTION file
11 ;
12 ;returns ien of #9002313.56 BPS PHARMACIES
13 ;or zero (0) if not found
14GETEPHRM(BPSDT,BPSRXIEN,BPSREF) ;*/
15 I +$G(BPSRXIEN)=0 Q 0
16 I $G(BPSREF)="" Q 0
17 N BP57,BP59,BPZ,BPFND,BPSPHRM
18 S BPFND=0,BPSPHRM=0
19 ;create a BPS TRANSACTION ien
20 S BP59=BPSRXIEN_"."_$E(((BPSREF_"1")+100000),2,6)
21 ;first look at BPS LOG file for the date
22 ;
23 I $G(BPSDT)>0 S BP57=0 F S BP57=$O(^BPSTL("B",BP59,BP57)) Q:(+BP57=0)!(BPFND>0) D
24 . I ($P($G(^BPSTL(BP57,0)),U,11)\1)=BPSDT S BPFND=BP57
25 ;if was found in BPS LOG
26 I BPFND>0 S BPSPHRM=+$P($G(^BPSTL(BPFND,1)),U,7) I BPSPHRM>0 Q BPSPHRM
27 ;if not get it from BPS TRANSACTION
28 S BPSPHRM=+$P($G(^BPST(BP59,1)),U,7) I BPSPHRM>0 Q BPSPHRM
29 ;if not then get it using PRESCRIPTION file's OUTPATIENT SITE
30 Q +$$EPHARM(BPSRXIEN,BPSREF)
31 ;
32 ;/*
33 ;returns ien of #9002313.56 BPS PHARMACIES associated
34 ;with the prescription specified by:
35 ; BPSRX - IEN in file #52
36 ; BPSREFIL - zero(0) for the original prescription or the refill
37 ; number for a refill (IEN of REFILL multiple #52.1)
38EPHARM(BPSRX,BPSREFIL) ;*/
39 I +$G(BPSRX)=0 Q ""
40 I $G(BPSREFIL)="" Q ""
41 N BPSDIV59
42 S BPSDIV59=+$$RXSITE^PSOBPSUT(+BPSRX,+BPSREFIL) ;IA #4701
43 I BPSDIV59>0 Q $$GETPHARM^BPSUTIL(BPSDIV59)
44 Q ""
45 ;
46 ; Delete BPS NCPDP FIELD DEF entries that are obsolete
47 ; for version 5.1 or are not Telecommunication standard
48DEL91 ;
49 N I,FLDNUM
50 ;
51 ; Fields in LIST are obsolete and/or not part of the Telecommunication standard
52 F I=1:1 S FLDNUM=$P($T(LIST+I),";",3) Q:FLDNUM="END" D DEL91A(FLDNUM)
53 ;
54 ; Fields 601+ are either obsolete and/or not part of the Telecommunication standard
55 S FLDNUM=600 F S FLDNUM=$O(^BPSF(9002313.91,"B",FLDNUM)) Q:+FLDNUM=0 D DEL91A(FLDNUM)
56 Q
57 ;
58DEL91A(FLDNUM) ;
59 N DIE,DA,DR
60 S DA=$O(^BPSF(9002313.91,"B",FLDNUM,""))
61 I DA="" Q
62 S DIE=9002313.91,DR=".01////@"
63 D ^DIE
64 Q
65 ;
66LIST ;;
67 ;;329
68 ;;404
69 ;;410
70 ;;416
71 ;;422
72 ;;425
73 ;;428
74 ;;432
75 ;;437
76 ;;508
77 ;;516
78 ;;525
79 ;;535
80 ;;END
Note: See TracBrowser for help on using the repository browser.