source: WorldVistAEHR/trunk/r/E_CLAIMS_MGMT_ENGINE-BPS/BPSJVAL2.m@ 1006

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

initial load of WorldVistAEHR

File size: 5.0 KB
Line 
1BPSJVAL2 ;BHAM ISC/LJF - Validate Pharmacy data ;2004-03-01
2 ;;1.0;E CLAIMS MGMT ENGINE;**1,2,5**;JUN 2004;Build 45
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 N PHARMIX,RET,DIR,X
6 ;
7 S PHARMIX=0,X=""
8 F S PHARMIX=$O(^BPS(9002313.56,PHARMIX)) Q:'PHARMIX D Q:X=U
9 . W !!,"VERIFY PHARMACY REGISTRATIONS DATA.",!
10 . D REG^BPSJPREG(PHARMIX,2)
11 . W !
12 . S DIR(0)="EO" D ^DIR
13 ;
14 Q
15 ;
16 ; Array HL and variable VERBOSE newed/set by calling routine
17 ; RETCODE returned to calling routine
18VALIDATE(BPSJDDD) ;
19 N SEG,SEGIX,ZRP,RAY,RIX,PIX,PIXL,SEGDAT,ZNOTE,ZMAX,CPS,FS,REP
20 N VALDATA,TMP
21 S ZMAX=17
22 ;
23 S RETCODE=$G(RETCODE)
24 S ZRP="",RIX=0
25 ;
26 ; Set HL7 Delimiters - use standard defaults if none provided
27 S FS=$G(HL("FS")) I FS="" S FS="|"
28 S CPS=$E($G(HL("ECH"))) I CPS="" S CPS="^"
29 S REP=$E($G(HL("ECH")),2) I REP="" S REP="~"
30 ;
31 F SEGIX=3:1 S SEG=$G(^TMP("HLS",$J,SEGIX)),PIX=0 Q:SEG="" D I ZRP]"" Q
32 . I $E(SEG,1,3)="ZRP" S ZRP=$E(SEG,4) S $E(SEG,1,4)=""
33 I ZRP="" Q
34 F S RIX=$O(^TMP("HLS",$J,SEGIX,RIX)) Q:'RIX I RIX<(ZMAX+1) D
35 . S TMP=$P($G(^TMP("HLS",$J,SEGIX,RIX)),ZRP)
36 . I $G(TMP)="" S RETCODE(RIX)=""
37 . I RIX=3 S RETCODE(RIX)=TMP ;capture pharmacy name
38 F S RIX=$O(RETCODE(RIX)) Q:'RIX D
39 . D @RIX
40 . I +$G(VERBOSE),$L($G(RETCODE(RIX))) W !,RETCODE(RIX)
41 ;
42 Q
43 ;
44 ; NS=Not Supported, R=Required, RE=Required or empty, C=Conditional
45 ; CE=Conditional or empty, O=Optional,
46 ;
471 ; Set ID - NS
48 Q
492 ; NCPDP Number - C
50 S ZNOTE=" NCPDP NUMBER - VALID"
51 I RETCODE(RIX)="" D
52 . I BPSJDDD=0 D
53 . . I '$D(RETCODE(17)) Q
54 . . S ZNOTE="** NCPDP NUMBER - NCPDP OR NPI - Missing/Invalid",RETCODE=2
55 . . S RETCODE(RIX)=ZNOTE_RETCODE(RIX)
56 Q
573 ; PHARMACY NAME - R
58 S ZNOTE=" PHARMACY NAME"
59 I RETCODE(RIX)="" D
60 . S ZNOTE="** PHARMACY NAME - Missing/Invalid",RETCODE=3
61 I RETCODE(RIX)]"" S RETCODE(RIX)=": "_$$DECODE(RETCODE(RIX))
62 S RETCODE(RIX)=ZNOTE_RETCODE(RIX)
63 Q
644 ; DEA Number - R
65 S ZNOTE=" DEA NUMBER - Required - VALID"
66 I RETCODE(RIX)="" D
67 . S ZNOTE="** DEA NUMBER - Missing/Invalid",RETCODE=4
68 . S RETCODE(RIX)=ZNOTE_RETCODE(RIX)
69 Q
705 ; Hour of Operation
71 S ZNOTE=" HOURS OF OPERATION - VALID"
72 Q
736 ; Mailing Address - R
74 S ZNOTE=$$TRIMTAIL(RETCODE(RIX))
75 S VALDATA=($L($P(ZNOTE,CPS,1))<1) ; Street address
76 S VALDATA=($L($P(ZNOTE,CPS,3))<1)+VALDATA ; City
77 S VALDATA=($L($P(ZNOTE,CPS,4))<1)+VALDATA ; State
78 S VALDATA=($L($P(ZNOTE,CPS,5))<1)+VALDATA ; Zip
79 S ZNOTE=" MAILING ADDRESS - Required - VALID"
80 I VALDATA D
81 . S ZNOTE="** MAILING ADDRESS - Missing/Invalid",RETCODE=6
82 . S RETCODE(RIX)=ZNOTE_RETCODE(RIX)
83 Q
847 ; Remittance Address - R
85 S ZNOTE=$$TRIMTAIL(RETCODE(RIX))
86 S VALDATA=($L($P(ZNOTE,CPS,1))<1) ; Street Address
87 S VALDATA=($L($P(ZNOTE,CPS,3))<1)+VALDATA ; City
88 S VALDATA=($L($P(ZNOTE,CPS,4))<1)+VALDATA ; State
89 S VALDATA=($L($P(ZNOTE,CPS,5))<1)+VALDATA ; Zip
90 S ZNOTE=" REMITTANCE ADDRESS - Required - VALID"
91 I VALDATA D
92 . S ZNOTE="** REMITTANCE ADDRESS - Missing/Invalid",RETCODE=7
93 . S RETCODE(RIX)=ZNOTE_RETCODE(RIX)
94 Q
958 ; Contact Name
96 S ZNOTE=$$TRIMTAIL(RETCODE(RIX))
97 S VALDATA=($L($P(ZNOTE,CPS,1))<1) ; Surname
98 S ZNOTE=" CONTACT NAME - Required - VALID"
99 I VALDATA D
100 . S ZNOTE="** CONTACT NAME - Missing/Invalid",RETCODE=8
101 . S RETCODE(RIX)=ZNOTE_RETCODE(RIX)
102 Q
1039 ; Contact Title
104 S ZNOTE=" CONTACT TITLE - VALID"
105 Q
10610 ; Contact means
107 S ZNOTE=" CONTACT MEANS - VALID"
108 ;S RETCODE(RIX)=ZNOTE_RETCODE(RIX)
109 Q
11011 ; Alternate Contact Name
111 S ZNOTE=$$TRIMTAIL(RETCODE(RIX))
112 S VALDATA=($L($P(ZNOTE,CPS,1))<1) ; Surname
113 S ZNOTE=" ALTERNATE CONTACT NAME - Required - VALID"
114 I VALDATA D
115 . S ZNOTE="** ALTERNATE CONTACT NAME - Missing/Invalid",RETCODE=11
116 . S RETCODE(RIX)=ZNOTE_RETCODE(RIX)
117 Q
11812 ; Alternate Contact Title
119 S ZNOTE=" ALTERNATE CONTACT TITLE - VALID"
120 Q
12113 ; Alternate Contact means
122 S ZNOTE=" ALTERNATE CONTACT MEANS - VALID"
123 Q
12414 ; Lead Pharmacist Name - R
125 S ZNOTE=$$TRIMTAIL(RETCODE(RIX))
126 S VALDATA=($L($P(ZNOTE,CPS,1))<1) ; Surname
127 S ZNOTE=" LEAD PHARMACIST NAME - Required - VALID"
128 I VALDATA D
129 . S ZNOTE="** LEAD PHARMACIST NAME - Missing/Invalid",RETCODE=14
130 . S RETCODE(RIX)=ZNOTE_RETCODE(RIX)
131 Q
13215 ; Lead Pharmacist Title
133 S ZNOTE=" LEAD PHARMACIST TITLE - VALID"
134 Q
13516 ; Lead Pharmacist License Number
136 S ZNOTE=" LEAD PHARMACIST LICENSE NUMBER - VALID"
137 Q
13817 ; NPI Number - C (R - AFTER DDD)
139 S ZNOTE=" NPI NUMBER - Required - VALID "
140 I RETCODE(RIX)="" D
141 . I BPSJDDD=0 D
142 . . I '$D(RETCODE(2)) S ZNOTE=" NPI NUMBER - Warning NPI NUMBER Missing " Q
143 . . S ZNOTE="** NPI NUMBER - NPI OR NCPDP - Missing/Invalid" S RETCODE=17
144 . I BPSJDDD>0 D
145 . . S ZNOTE="** NPI NUMBER - Missing/Invalid" S RETCODE=17
146 . S RETCODE(RIX)=ZNOTE_RETCODE(RIX)
147 Q
148 ;
149TRIMTAIL(INSTR) ;
150 N OUTSTR,CHR
151 ;
152 I $G(INSTR)="" Q "" ; quit if nothing there
153 ;
154 S INSTR=$RE(INSTR)
155 S CHR=$E($TR(INSTR,CPS_REP))
156 I CHR]"" Q $RE($P(INSTR,CHR,2,200))_CHR
157 Q ""
158 ;
159 ; DECODE - Normalize data for display
160 ; Input:
161 ; INSTR - String to normalize
162 ; Output
163 ; Normalize data
164DECODE(INSTR) ;
165 N TRCH
166 S TRCH("\F\")="|",TRCH("\R\")="~",TRCH("\E\")="\"
167 S TRCH("\T\")="&",TRCH("\S\")="^"
168 Q $$DECODE^BPSJZPR(INSTR,.TRCH)
Note: See TracBrowser for help on using the repository browser.