source: FOIAVistA/trunk/r/E_CLAIMS_MGMT_ENGINE-BPS/BPSJZRP.m@ 1783

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

initial load of FOIAVistA 6/30/08 version
File size: 4.7 KB
Line 
1BPSJZRP ;BHAM ISC/LJF - HL7 Registration ZRP Message ;21-NOV-2003
2 ;;1.0;E CLAIMS MGMT ENGINE;**1,2**;JUN 2004;Build 12
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 Q
6 ;
7EN(HL,PHIX,ZRP,NPI,NCP) ;
8 ; ZRP array contains pharmacy registration info
9 N ZRPS,FS,CPS,REP,NDZRO,NDHRS,NDREM,NDREP,NDREP1,NDADD,STATE
10 N VAIX1,VAIX2,VAIXLP,VATLE,CNF,MSGCNT,TCH
11 ;
12 ; Quit if no Pharmacy index provided
13 I '$G(PHIX) Q
14 ;
15 K ZRP S ZRPS=""
16 ;
17 ; Set HL7 Delimiters - use standard defaults if none provided
18 S FS=$G(HL("FS")) I FS="" S FS="|"
19 S CPS=$E($G(HL("ECH"))) I CPS="" S CPS="^"
20 S REP=$E($G(HL("ECH")),2) I REP="" S REP="~"
21 ;
22 S NDZRO=$G(^BPS(9002313.56,PHIX,0))
23 S NDREM=$G(^BPS(9002313.56,PHIX,"REMIT"))
24 S NDREP=$G(^BPS(9002313.56,PHIX,"REP"))
25 S NDREP1=$G(^BPS(9002313.56,PHIX,"REP1"))
26 S NDADD=$G(^BPS(9002313.56,PHIX,"ADDR"))
27 ;
28 F ZRP=1:1:17 S ZRP(ZRP)="" ;Initialize
29 S (ZRP(2),NCP)=$P(NDZRO,U,2) ;NCPDP #
30 S ZRP(3)=$P(NDZRO,U) ;NAME
31 S ZRP(4)=$P(NDZRO,U,3) ;DEFAULT DEA #
32 ;
33 S ZRP(5)=$$OPHOURS(PHIX)
34 ;
35 I $L($P(NDADD,U,8)) S $P(ZRPS,CPS,1)=$P(NDADD,U,8) ;SITE ADDRESS NAME
36 I $L($P(NDADD,U,1)) S $P(ZRPS,CPS,1)=$P(ZRPS,CPS,1)_" "_$P(NDADD,U,1) ;SITE ADDRESS 1
37 I $L($P(NDADD,U,2)) S $P(ZRPS,CPS,2)=$P(NDADD,U,2) ;SITE ADDRESS 2
38 I $L($P(NDADD,U,3)) S $P(ZRPS,CPS,3)=$P(NDADD,U,3) ;CITY
39 I $L($P(NDADD,U,4)) S STATE=$P(NDADD,U,4) I STATE D ; State
40 . S STATE=$P($G(^DIC(5,STATE,0)),U,2)
41 . I STATE]"" S $P(ZRPS,CPS,4)=STATE
42 I $L($P(NDADD,U,5)) S $P(ZRPS,CPS,5)=$P(NDADD,U,5) ;ZIP
43 I ZRPS]"" S ZRP(6)=ZRPS,ZRPS=""
44 ;
45 I $L($P(NDREM,U,1)) S $P(ZRPS,CPS,1)=$P(NDREM,U,1) ;REMITTANCE ADDRESS NAME
46 I $L($P(NDREM,U,2)) S $P(ZRPS,CPS,1)=$P(ZRPS,CPS,1)_" "_$P(NDREM,U,2) ;REMIT ADDRESS LINE 1
47 I $L($P(NDREM,U,3)) S $P(ZRPS,CPS,2)=$P(NDREM,U,3) ;REMIT ADDRESS LINE 2
48 I $L($P(NDREM,U,6)) S $P(ZRPS,CPS,3)=$P(NDREM,U,6) ;CITY
49 I $L($P(NDREM,U,7)) S STATE=$P(NDREM,U,7) I STATE D ;State
50 . S STATE=$P($G(^DIC(5,STATE,0)),U,2)
51 . I STATE]"" S $P(ZRPS,CPS,4)=STATE
52 I $L($P(NDREM,U,8)) S $P(ZRPS,CPS,5)=$P(NDREM,U,8) ;ZIP
53 I ZRPS]"" S ZRP(7)=ZRPS,ZRPS=""
54 ;
55 ; Load the Name and Means Fields
56 S VAIX1=$P(NDREP,U,3)
57 S VAIX2=$P(NDREP,U,4)
58 S VAIXLP=$P(NDREP,U,5)
59 ;
60 ; Contact
61 I $G(VAIX1) S VATLE="" D
62 . S CNF=$$VA200NM^BPSJUTL(VAIX1,.VATLE,.HL) I CNF]"" S ZRP(8)=CNF
63 . I VATLE]"" S ZRP(9)=VATLE
64 . S CNF=$$VA20013^BPSJUTL(VAIX1,.HL) I CNF]"" S ZRP(10)=CNF
65 ;
66 ; Alternate Contact
67 I $G(VAIX2) S VATLE="" D
68 . S CNF=$$VA200NM^BPSJUTL(VAIX2,.VATLE,.HL) I CNF]"" S ZRP(11)=CNF
69 . I VATLE]"" S ZRP(12)=VATLE
70 . S CNF=$$VA20013^BPSJUTL(VAIX2,.HL) I CNF]"" S ZRP(13)=CNF
71 ;
72 ; Lead Pharmacist
73 I $G(VAIXLP) S VATLE="" D
74 . S CNF=$$VA200NM^BPSJUTL(VAIXLP,.VATLE,.HL) I CNF]"" S ZRP(14)=CNF
75 . I VATLE]"" S ZRP(15)=VATLE
76 ;
77 ; Pharmacist's License
78 I $L($P(NDREP1,U)) S ZRP(16)=$P(NDREP1,U)
79 ;
80 ; NPI
81 S ZRP(17)=$G(NPI)
82 ;
83 ; Encode special chars. Add Field separators.
84 S TCH("\")="\E\",TCH("&")="\T\",TCH("|")="\F\"
85 S (ZRPS(5),ZRPS(10),ZRPS(13))=1 ;Fields with HL7 repetion chars
86 F ZRP=17:-1:1 D S ZRP(ZRP)=$$ENCODE^BPSJUTL(ZRP(ZRP),.TCH)_FS
87 . I $G(ZRPS(ZRP)) K TCH("~") ; don't convert repetion chars
88 . E S TCH("~")="\R\" ; ok to convert repetion chars
89 S ZRP="ZRP|"
90 ;
91 Q
92 ;
93OPHOURS(PHINDEX) ; Operational Hours
94 N DAY,DIX,OPH,RETURN,WEEK,OPDAY,OPHOUR
95 N CLH
96 ;
97 S PHINDEX=+$G(PHINDEX),RETURN=""
98 S WEEK="SUN^MON^TUE^WED^THU^FRI^SAT^"
99 S OPH=$G(^BPS(9002313.56,PHINDEX,"TOPEN"))
100 S CLH=$G(^BPS(9002313.56,PHINDEX,"TCLOSE"))
101 I $G(CPS)="" S CPS=$E($G(HL("ECH"))) I CPS="" S CPS="^"
102 I $G(REP)="" S REP=$E($G(HL("ECH")),2) I REP="" S REP="~"
103 I OPH]"" F DAY=1:1:7 I $P(OPH,U,DAY)]"" D
104 . I RETURN]"" S RETURN=RETURN_REP
105 . S RETURN=RETURN_$P(WEEK,U,DAY)_CPS_$P(WEEK,U,DAY)_CPS
106 . S OPHOUR=$$HOURS($P(OPH,U,DAY)) I OPHOUR<0 S OPHOUR="0000"
107 . S RETURN=RETURN_OPHOUR_CPS
108 . S OPHOUR=$$HOURS($P(CLH,U,DAY)) I OPHOUR<0 S OPHOUR="2359"
109 . S RETURN=RETURN_OPHOUR
110 I RETURN]"" Q RETURN
111 ;
112 S WEEK=U_WEEK
113 S OPH=$G(^BPS(9002313.56,PHINDEX,"HOURS"))
114 S OPDAY=$E($P(OPH,U,2),1,3)
115 ;-if start day unrecognizable force to SUN
116 I WEEK[(U_OPDAY_U) S RETURN=OPDAY_CPS
117 E S RETURN="SUN"_CPS
118 S OPDAY=$E($P(OPH,U,3),1,3)
119 ;-if end day unrecognizable force to SAT
120 I WEEK[(U_OPDAY_U) S RETURN=RETURN_OPDAY_CPS
121 E S RETURN=RETURN_"SAT"_CPS
122 ;-if start time unrecognizable force to 0000
123 S OPHOUR=$$HOURS($E($P(OPH,U,4),1,4)) I OPHOUR<0 S OPHOUR="0000"
124 ;-if end time unrecognizable force to 2359
125 S OPDAY=$$HOURS($E($P(OPH,U,5),1,4)) I OPDAY<0 S OPDAY="2359"
126 ;-if end time is less than start time force 0000 to 2359
127 I OPDAY>OPHOUR S RETURN=RETURN_OPHOUR_CPS_OPDAY
128 E S RETURN=RETURN_"0000"_CPS_"2359"
129 Q RETURN
130 ;
131HOURS(MIN) ; Validate time 0000 - 2359
132 N HRS
133 S HRS=$E(MIN,1,2),$E(MIN,1,2)=""
134 I $L(HRS)=2,HRS>-1,HRS<24,$L(MIN)=2,MIN>-1,MIN<60 Q HRS_MIN
135 Q -1
Note: See TracBrowser for help on using the repository browser.