BPSJINIT ;BHAM ISC/LJF - HL7 Application Registration ;03/07/08 14:09
;;1.0;E CLAIMS MGMT ENGINE;**1,3,2,5,7**;JUN 2004;Build 46
;;Per VHA Directive 2004-038, this routine should not be modified.
;
N DA,DIC,DIE,DINUM,DIR,DIRUT,DIROUT,DLAYGO,DR,DTOUT,DUOUT,X,Y
N BPSJAPPR,BPSJVALR,PHIX,BPSOUT
;
; This program will allow user to enter site data.
;
; Programmer Note: D BPSJVAL^BPSJAREG(X) will validate with following.
; where X is: 0 = HL7 trigger, no validation display
; 1 = HL7 trigger, display validation
; 2 = no HL7 trigger, display validation
; 3 = no validation display, no HL7 trigger
;
W !!,?IOM/2-14,"** ECME Site Registration **"
;
; Create/update BPS Setup record
D VERSION
;
S BPSOUT=0
S DIE="^BPS(9002313.99,",DA=1
S DR="[BPSJ SITE SETUP]" D ^DIE
I BPSOUT!($D(Y)) Q
;
W !!!,"-- Application Registration Validation Results:"
S BPSJVALR=-1
D BPSJVAL^BPSJAREG(2)
S BPSJAPPR=BPSJVALR
;
I 'BPSJAPPR W !!,?IOM/2-21,"** Application Registration Data VALID **",!
E D
. W !!,"** Application Registration Data INVALID!!! **"
. W !,"** Application Registration and Pharmacy **"
. W !,"** Registrations will NOT be sent! **",!
;
S DIR(0)="EO" D ^DIR I X=U Q
;
D PHARM(.BPSOUT)
I BPSOUT Q
I BPSJAPPR D Q
. W !!,"Registration ABORTED due to invalid site registration data",!!
;
W !!!,"Application Registration Data is VALID"
W !!,"Pharmacy Registration Data is:"
S PHIX=$O(^BPS(9002313.56,0))
F Q:'PHIX D S PHIX=$O(^BPS(9002313.56,PHIX))
. S BPSJVALR=-1 D REG^BPSJPREG(PHIX,3)
. I BPSJVALR>0 S DIR=" *INVALID",DIE=" and will NOT be transmitted."
. E S DIR=" VALID",DIE=" and will be transmitted."
. W !,DIR_" for "_$P($G(^BPS(9002313.56,PHIX,0)),U)_DIE
W !
K DA,DIC,DIE,DINUM,DIR,DIRUT,DIROUT,DLAYGO,DR,DTOUT,DUOUT,X,Y
S DIR(0)="YEO",DIR("A")="Send Application Registration: Y/N " D ^DIR
I $TR($E(X),"y","Y")'="Y" Q
;
K DA,DIC,DIE,DINUM,DIR,DIRUT,DIROUT,DLAYGO,DR,DTOUT,DUOUT,X,Y
D BPSJVAL^BPSJAREG(0)
W !!,"Application Registration SUBMITTED..."
Q
;
PHARM(BPSOUT) ;CYCLE THROUGH PHARMACIES
;
N DA,DIC,DIE,DINUM,DIR,DIRUT,DIROUT,DLAYGO,DR,DTOUT,DUOUT,X,Y
N BPSJVALR,BPSJPHPR,BPSPHARM
;
S BPSPHARM=0 F D Q:BPSPHARM=""!(BPSOUT)
. W !!!,"Enter/verify Pharmacy Registration Data"
. ;
. ;check for drop dead date
. S DIC(0)="QAELM"
. S DIC="^BPS(9002313.56,",DLAYGO=DIC D ^DIC
. ;
. I X'=U,0<+Y S BPSPHARM=+Y
. E S BPSPHARM="" Q
. D MOD(BPSPHARM,.BPSOUT) I 'BPSPHARM!(BPSOUT) Q
. W !!!,"-- Pharmacy Registration Validation Results --",!
. ;
. S BPSJVALR=-1
. D REG^BPSJPREG(BPSPHARM,2)
. S BPSJPHPR=BPSJVALR
. ;
. I 'BPSJPHPR W !!,"-- Pharmacy Registration Data VALID. --",!
. E D
.. W !!,"** Pharmacy Registration Data INVALID!!! **"
.. W !,"** This pharmacy's registration will NOT be sent! **",!
;
Q
;
MOD(DA,BPSOUT) ;
N DIE,DR,DTOUT,X,Y
;
; Set STATUS default to ACTIVE if not set
I $P($G(^BPS(9002313.56,DA,0)),"^",10)="" D
. S DR=".1///ACTIVE",DIE="^BPS(9002313.56,"
. D ^DIE
;
S DIE="^BPS(9002313.56,"
S DR="[BPSJ PHARMACY ENTER/EDIT]" D ^DIE
I $D(Y) S BPSOUT=1
;
Q
;
VERSION ;
; Create entry if missing
; Sets in defaults:
; ECME TIMEOUT: 10
; SITE TYPE: VA
; WINNOW TESTING FLAG: NO
; VA LAST SEQUENCE: = $P($P($G(^BPSC(+$P(^BPSC(0),U,3),0)),U),?=?,4)
; WINNOW BPS LOG: 36
; VITRIA INTERFACE VERSION: 3
;
N BPSDA,DIC,DLAYGO,X,Y,DTOUT,DUOUT,DINUM
S BPSDA=$O(^BPS(9002313.99,0))
I BPSDA'=1 D
. S (DIC,DLAYGO)=9002313.99,DIC(0)="L",X="MAIN SETUP ENTRY",DINUM=1
. S DIC("DR")="3.01///10;1000///^S X=$P($P($G(^BPSC(+$P(^BPSC(0),U,3),0)),U),"=",4);9999///VA;6003///3;2341.01///NO;2341.03///36"
. D ^DIC
;
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HBPSJINIT 3849 printed Dec 13, 2024@01:51:01 Page 2
BPSJINIT ;BHAM ISC/LJF - HL7 Application Registration ;03/07/08 14:09
+1 ;;1.0;E CLAIMS MGMT ENGINE;**1,3,2,5,7**;JUN 2004;Build 46
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 NEW DA,DIC,DIE,DINUM,DIR,DIRUT,DIROUT,DLAYGO,DR,DTOUT,DUOUT,X,Y
+5 NEW BPSJAPPR,BPSJVALR,PHIX,BPSOUT
+6 ;
+7 ; This program will allow user to enter site data.
+8 ;
+9 ; Programmer Note: D BPSJVAL^BPSJAREG(X) will validate with following.
+10 ; where X is: 0 = HL7 trigger, no validation display
+11 ; 1 = HL7 trigger, display validation
+12 ; 2 = no HL7 trigger, display validation
+13 ; 3 = no validation display, no HL7 trigger
+14 ;
+15 WRITE !!,?IOM/2-14,"** ECME Site Registration **"
+16 ;
+17 ; Create/update BPS Setup record
+18 DO VERSION
+19 ;
+20 SET BPSOUT=0
+21 SET DIE="^BPS(9002313.99,"
SET DA=1
+22 SET DR="[BPSJ SITE SETUP]"
DO ^DIE
+23 IF BPSOUT!($DATA(Y))
QUIT
+24 ;
+25 WRITE !!!,"-- Application Registration Validation Results:"
+26 SET BPSJVALR=-1
+27 DO BPSJVAL^BPSJAREG(2)
+28 SET BPSJAPPR=BPSJVALR
+29 ;
+30 IF 'BPSJAPPR
WRITE !!,?IOM/2-21,"** Application Registration Data VALID **",!
+31 IF '$TEST
Begin DoDot:1
+32 WRITE !!,"** Application Registration Data INVALID!!! **"
+33 WRITE !,"** Application Registration and Pharmacy **"
+34 WRITE !,"** Registrations will NOT be sent! **",!
End DoDot:1
+35 ;
+36 SET DIR(0)="EO"
DO ^DIR
IF X=U
QUIT
+37 ;
+38 DO PHARM(.BPSOUT)
+39 IF BPSOUT
QUIT
+40 IF BPSJAPPR
Begin DoDot:1
+41 WRITE !!,"Registration ABORTED due to invalid site registration data",!!
End DoDot:1
QUIT
+42 ;
+43 WRITE !!!,"Application Registration Data is VALID"
+44 WRITE !!,"Pharmacy Registration Data is:"
+45 SET PHIX=$ORDER(^BPS(9002313.56,0))
+46 FOR
if 'PHIX
QUIT
Begin DoDot:1
+47 SET BPSJVALR=-1
DO REG^BPSJPREG(PHIX,3)
+48 IF BPSJVALR>0
SET DIR=" *INVALID"
SET DIE=" and will NOT be transmitted."
+49 IF '$TEST
SET DIR=" VALID"
SET DIE=" and will be transmitted."
+50 WRITE !,DIR_" for "_$PIECE($GET(^BPS(9002313.56,PHIX,0)),U)_DIE
End DoDot:1
SET PHIX=$ORDER(^BPS(9002313.56,PHIX))
+51 WRITE !
+52 KILL DA,DIC,DIE,DINUM,DIR,DIRUT,DIROUT,DLAYGO,DR,DTOUT,DUOUT,X,Y
+53 SET DIR(0)="YEO"
SET DIR("A")="Send Application Registration: Y/N "
DO ^DIR
+54 IF $TRANSLATE($EXTRACT(X),"y","Y")'="Y"
QUIT
+55 ;
+56 KILL DA,DIC,DIE,DINUM,DIR,DIRUT,DIROUT,DLAYGO,DR,DTOUT,DUOUT,X,Y
+57 DO BPSJVAL^BPSJAREG(0)
+58 WRITE !!,"Application Registration SUBMITTED..."
+59 QUIT
+60 ;
PHARM(BPSOUT) ;CYCLE THROUGH PHARMACIES
+1 ;
+2 NEW DA,DIC,DIE,DINUM,DIR,DIRUT,DIROUT,DLAYGO,DR,DTOUT,DUOUT,X,Y
+3 NEW BPSJVALR,BPSJPHPR,BPSPHARM
+4 ;
+5 SET BPSPHARM=0
FOR
Begin DoDot:1
+6 WRITE !!!,"Enter/verify Pharmacy Registration Data"
+7 ;
+8 ;check for drop dead date
+9 SET DIC(0)="QAELM"
+10 SET DIC="^BPS(9002313.56,"
SET DLAYGO=DIC
DO ^DIC
+11 ;
+12 IF X'=U
IF 0<+Y
SET BPSPHARM=+Y
+13 IF '$TEST
SET BPSPHARM=""
QUIT
+14 DO MOD(BPSPHARM,.BPSOUT)
IF 'BPSPHARM!(BPSOUT)
QUIT
+15 WRITE !!!,"-- Pharmacy Registration Validation Results --",!
+16 ;
+17 SET BPSJVALR=-1
+18 DO REG^BPSJPREG(BPSPHARM,2)
+19 SET BPSJPHPR=BPSJVALR
+20 ;
+21 IF 'BPSJPHPR
WRITE !!,"-- Pharmacy Registration Data VALID. --",!
+22 IF '$TEST
Begin DoDot:2
+23 WRITE !!,"** Pharmacy Registration Data INVALID!!! **"
+24 WRITE !,"** This pharmacy's registration will NOT be sent! **",!
End DoDot:2
End DoDot:1
if BPSPHARM=""!(BPSOUT)
QUIT
+25 ;
+26 QUIT
+27 ;
MOD(DA,BPSOUT) ;
+1 NEW DIE,DR,DTOUT,X,Y
+2 ;
+3 ; Set STATUS default to ACTIVE if not set
+4 IF $PIECE($GET(^BPS(9002313.56,DA,0)),"^",10)=""
Begin DoDot:1
+5 SET DR=".1///ACTIVE"
SET DIE="^BPS(9002313.56,"
+6 DO ^DIE
End DoDot:1
+7 ;
+8 SET DIE="^BPS(9002313.56,"
+9 SET DR="[BPSJ PHARMACY ENTER/EDIT]"
DO ^DIE
+10 IF $DATA(Y)
SET BPSOUT=1
+11 ;
+12 QUIT
+13 ;
VERSION ;
+1 ; Create entry if missing
+2 ; Sets in defaults:
+3 ; ECME TIMEOUT: 10
+4 ; SITE TYPE: VA
+5 ; WINNOW TESTING FLAG: NO
+6 ; VA LAST SEQUENCE: = $P($P($G(^BPSC(+$P(^BPSC(0),U,3),0)),U),?=?,4)
+7 ; WINNOW BPS LOG: 36
+8 ; VITRIA INTERFACE VERSION: 3
+9 ;
+10 NEW BPSDA,DIC,DLAYGO,X,Y,DTOUT,DUOUT,DINUM
+11 SET BPSDA=$ORDER(^BPS(9002313.99,0))
+12 IF BPSDA'=1
Begin DoDot:1
+13 SET (DIC,DLAYGO)=9002313.99
SET DIC(0)="L"
SET X="MAIN SETUP ENTRY"
SET DINUM=1
+14 SET DIC("DR")="3.01///10;1000///^S X=$P($P($G(^BPSC(+$P(^BPSC(0),U,3),0)),U),"=",4);9999///VA;6003///3;2341.01///NO;2341.03///36"
+15 DO ^DIC
End DoDot:1
+16 ;
+17 QUIT
+18 ;
