source: WorldVistAEHR/trunk/r/E_CLAIMS_MGMT_ENGINE-BPS/BPSJINIT.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: 5.7 KB
Line 
1BPSJINIT ;BHAM ISC/LJF - HL7 Application Registration ;21-NOV-2003
2 ;;1.0;E CLAIMS MGMT ENGINE;**1,3,2,5**;JUN 2004;Build 45
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 N DA,DIC,DIE,DINUM,DIR,DIRUT,DIROUT,DLAYGO,DR,DTOUT,DUOUT,X,Y
6 N BPVALFN,BPSJAPPR,BPSJVALR,PHIX
7 ;
8 ; This program will allow user to enter site data.
9 ;
10 ; Programmer Note: D BPSJVAL^BPSJAREG(X) will validate with following.
11 ; where X is: 0 = HL7 trigger, no validation display
12 ; 1 = HL7 trigger, display validation
13 ; 2 = no HL7 trigger, display validation
14 ; 3 = no validation display, no HL7 trigger
15 ;
16 W !!!,"ENTER/VERIFY SITE REGISTRATION DATA.",!!
17 ;
18 S BPVALFN=9002313.99
19 ;
20 ; Create/update BPS Setup record
21 ; Returns record number in DA
22 D VERSION(BPVALFN)
23 ;
24 W !!,"PRIMARY SITE CONTACT DATA."
25 K DIC,DIE,DINUM,DIR,DIRUT,DIROUT,DLAYGO,DR,DTOUT,DUOUT,X,Y
26 S DIE=$$ROOT^DILFD(BPVALFN)
27 S DR="[BPSJ CONTACT ENTER/EDIT]" D ^DIE
28 ;
29 W !!,"ALTERNATE SITE CONTACT DATA."
30 K DIC,DIE,DINUM,DIR,DIRUT,DIROUT,DLAYGO,DR,DTOUT,DUOUT,X,Y
31 S DIE=$$ROOT^DILFD(BPVALFN)
32 S DR="[BPSJ ALT CONTACT ENTER/EDIT]" D ^DIE
33 ;
34 W !!!,"-- APPLICATION REGISTRATION VALIDATION RESULTS. --",!!
35 S BPSJVALR=-1
36 D BPSJVAL^BPSJAREG(2)
37 S BPSJAPPR=BPSJVALR
38 ;
39 I 'BPSJAPPR W !!,"-- APPLICATION REGISTRATION DATA VALID. --",!
40 E D
41 . W !!,"** APPLICATION REGISTRATION DATA INVALID!!! **"
42 . W !,"** APPLICATION REGISTRATION AND PHARMACY **"
43 . W !,"** REGISTRATIONS WILL NOT BE SENT! **",!
44 ;
45 K DA,DIC,DIE,DINUM,DIR,DIRUT,DIROUT,DLAYGO,DR,DTOUT,DUOUT,X,Y
46 S DIR(0)="EO" D ^DIR I X=U Q
47 ;
48 D PHARM
49 I BPSJAPPR D Q
50 . W !!,"REGISTRATION ABORTED DUE TO INVALID SITE REGISTRATION DATA.",!!
51 ;
52 W !!!,"APPLICATION REGISTRATION DATA IS VALID."
53 W !!,"PHARMACY REGISTRATION DATA IS:"
54 S PHIX=$O(^BPS(9002313.56,0))
55 F Q:'PHIX D S PHIX=$O(^BPS(9002313.56,PHIX))
56 . S BPSJVALR=-1 D REG^BPSJPREG(PHIX,3)
57 . I BPSJVALR>0 S DIR=" *INVALID",DIE=" and will NOT be transmitted."
58 . E S DIR=" VALID",DIE=" and will be transmitted."
59 . W !,DIR_" for "_$P($G(^BPS(9002313.56,PHIX,0)),U)_DIE
60 W !
61 K DA,DIC,DIE,DINUM,DIR,DIRUT,DIROUT,DLAYGO,DR,DTOUT,DUOUT,X,Y
62 S DIR(0)="YEO",DIR("A")="SEND APPLICATION REGISTRATION: Y/N " D ^DIR
63 I $TR($E(X),"y","Y")'="Y" Q
64 ;
65 K DA,DIC,DIE,DINUM,DIR,DIRUT,DIROUT,DLAYGO,DR,DTOUT,DUOUT,X,Y
66 D BPSJVAL^BPSJAREG(0)
67 W !!,"APPLICATION REGISTRATION SUBMITTED."
68 Q
69 ;
70PHARM ;CYCLE THROUGH PHARMACIES
71 ;
72 N DA,DIC,DIE,DINUM,DIR,DIRUT,DIROUT,DLAYGO,DR,DTOUT,DUOUT,X,Y
73 N BPVALFN,BPSJVALR,BPSJPHPR
74 ;
75 ;
76 ; Check DropDeadDate
77 N BPSJDDD
78 S BPSJDDD=$$NPIREQ^BPSNPI(DT) ; DDD=3080524
79 ;
80 S BPVALFN=9002313.56,PHIX=0
81 ;
82 F D Q:PHIX=""
83 . W !!!,"ENTER/VERIFY PHARMACY REGISTRATION DATA."
84 . W !!,"PHARMACY SPECIFIC DATA."
85 . K DA,DIC,DIE,DINUM,DIR,DIRUT,DIROUT,DLAYGO,DR,DTOUT,DUOUT,X,Y
86 . ;check for drop dead date
87 . S DIC(0)="QAELM" I $G(BPSJDDD)>0 S DIC(0)="QAEM"
88 . S DIC=BPVALFN,DLAYGO=DIC D ^DIC
89 . ;
90 . I X'=U,0<+Y S PHIX=+Y
91 . E S PHIX="" Q
92 . D MOD I 'PHIX Q
93 . W !!!,"-- PHARMACY REGISTRATION VALIDATION RESULTS. --",!
94 . ;
95 . S BPSJVALR=-1
96 . D REG^BPSJPREG(PHIX,2)
97 . S BPSJPHPR=BPSJVALR
98 . ;
99 . I 'BPSJPHPR W !!,"-- PHARMACY REGISTRATION DATA VALID. --",!
100 . E D
101 .. W !!,"** PHARMACY REGISTRATION DATA INVALID!!! **"
102 .. W !,"** THIS PHARMACY'S REGISTRATION WILL NOT BE SENT! **",!
103 . ;
104 . K DA,DIC,DIE,DINUM,DIR,DIRUT,DIROUT,DLAYGO,DR,DTOUT,DUOUT,X,Y
105 . S DIR(0)="EO",DIR("A")="Enter RETURN to continue" D ^DIR
106 ;
107 Q
108 ;
109MOD ;
110 N DA,DIC,DIE,DINUM,DIR,DIRUT,DIROUT,DLAYGO,DR,DTOUT,DUOUT,X,Y
111 ;
112 ; Set hours to default if not set.
113 S DA=$$OPHOURS^BPSJZRP(PHIX),DR=$G(^BPS(9002313.56,PHIX,"HOURS"))
114 I $P(DR,U,2,5)'=DA S ^BPS(9002313.56,PHIX,"HOURS")="24"_U_DA
115 ;
116 ; Set STATUS default to ACTIVE if not set
117 I $$GET1^DIQ(9002313.56,PHIX,.1,"I")="" D
118 . K DI,DIDEL
119 . S DR=".1///ACTIVE",DIE=9002313.56,DA=PHIX
120 . D ^DIE
121 ;
122 W !!,"SITE DATA."
123 K DA,DIC,DIE,DINUM,DIR,DIRUT,DIROUT,DLAYGO,DR,DTOUT,DUOUT,X,Y
124 S DA=PHIX,DIE=$$ROOT^DILFD(BPVALFN)
125 S DR="[BPSJ PHARMACY SITE ENTER/EDIT]" D ^DIE
126 ;
127 I '$G(DA) S PHIX=0 Q ; Pharmacy killed by user
128 ;
129 ; Pharmacy open hours
130 I '$D(Y) D EN^BPSJINI1(PHIX)
131 ;
132 K DA,DIC,DIE,DINUM,DIR,DIRUT,DIROUT,DLAYGO,DR,DTOUT,DUOUT,X,Y
133 S DIR(0)="EO" D ^DIR
134 ;
135 I X=U Q
136 ;
137 W !!,"PRIMARY CONTACT DATA."
138 K DA,DIC,DIE,DINUM,DIR,DIRUT,DIROUT,DLAYGO,DR,DTOUT,DUOUT,X,Y
139 S DA=PHIX,DIE=$$ROOT^DILFD(BPVALFN)
140 S DR="[BPSJ PHARM CONTACT ENTER/EDIT]" D ^DIE
141 ;
142 K DA,DIC,DIE,DINUM,DIR,DIRUT,DIROUT,DLAYGO,DR,DTOUT,DUOUT,X,Y
143 S DIR(0)="EO" D ^DIR
144 ;
145 I X=U Q
146 ;
147 W !!,"ALTERNATE CONTACT DATA."
148 K DA,DIC,DIE,DINUM,DIR,DIRUT,DIROUT,DLAYGO,DR,DTOUT,DUOUT,X,Y
149 S DA=PHIX,DIE=$$ROOT^DILFD(BPVALFN)
150 S DR="[BPSJ PHARM ALT CONT ENTER/EDIT]" D ^DIE
151 ;
152 K DA,DIC,DIE,DINUM,DIR,DIRUT,DIROUT,DLAYGO,DR,DTOUT,DUOUT,X,Y
153 S DIR(0)="EO" D ^DIR
154 ;
155 I X=U Q
156 ;
157 W !!,"PHARMACIST DATA." ; VA LEAD PHARMACIST
158 K DA,DIC,DIE,DINUM,DIR,DIRUT,DIROUT,DLAYGO,DR,DTOUT,DUOUT,X,Y
159 S DA=PHIX,DIE=$$ROOT^DILFD(BPVALFN)
160 S DR="[BPSJ PHARMACIST ENTER/EDIT]" D ^DIE
161 ;
162 I $D(Y) Q
163 ;
164 ; VA LEAD PHARMACIST LICENSE
165 K DA,DIC,DIE,DINUM,DIR,DIRUT,DIROUT,DLAYGO,DR,DTOUT,DUOUT,X,Y
166 S DA=PHIX,DIE=$$ROOT^DILFD(BPVALFN)
167 S DR="1900.04//" D ^DIE
168 ;
169 Q
170 ;
171 ; Create record if it is missing
172 ; Set version number to 3
173 ; Return record number
174VERSION(BPVAL) ;
175 I '$G(BPVAL) Q
176 S DA=$O(^BPS(BPVAL,0))
177 I 'DA D
178 . N DIC,DLAYGO,DR,X,Y,DTOUT,DUOUT
179 . S (DIC,DLAYGO)=BPVAL,DIC(0)="L",X="MAIN SETUP ENTRY" D ^DIC
180 . S DA=+Y
181 I DA=-1 Q
182 N DIE,DR,DTOUT
183 S DIE=BPVAL,DR="6003////3" D ^DIE
184 Q
185 ;
186VALIDATE ; this will only validate the Application Registration and
187 ; the Pharmacy registrations
188 Q
189 N AREG
190 ;
191 D BPSJVAL^BPSJAREG(2)
192 ;
193 S DIR(0)="EO"
194 D ^DIR
195 I X=U Q
196 ;
197 S AREG="" F S AREG=$O(^BPS(9002313.56,AREG)) Q:'AREG D I X=U Q
198 . D REG^BPSJPREG(AREG,2)
199 . S DIR(0)="EO"
200 . D ^DIR
201 ;
202 Q
Note: See TracBrowser for help on using the repository browser.