IBYBPRE ;ALB/ARH - PATCH IB*2*27 ENVIRONMENT CHECK ; 10-FEB-95
;;Version 2.0 ; INTEGRATED BILLING ;**27**; 21-MAR-94
;
EN ; Perform checks to be sure IB*2*27 can be installed.
;
W ! S IBQ=0
;
D CHKUSR I IBQ G ENQ ; check DUZ and DUZ(0)
;
I $$RERUN() G ENQ ; skip checks if it appears init is being re-run
;
D CHKAR ; make sure patch PRCA*4*15 or PRCA*4.5*1 is installed
D CHKIB ; make sure IB parameters are in place
;
I IBQ K DIFQ ; stop the install if there is a problem
;
ENQ K IBQ
Q
;
;
CHKUSR ; Check DUZ and DUZ(0).
I $S('($D(DUZ)#2):1,'$D(^VA(200,+DUZ,0)):1,'$D(DUZ(0)):1,1:0) D
.W !!?3,"The variable DUZ must be set to an active user code and the variable"
.W !?3,"DUZ(0) must also be defined to run this initialization.",!
.K DIFQ S IBQ=1
Q
;
CHKAR ; Make sure patch PRCA*4*15 or PRCA*4.5*1 is properly installed.
S IBCTPN="CHAMPVA THIRD PARTY",IBCTP=$O(^PRCA(430.2,"B",IBCTPN,0))
S IBCCVN="CHAMPVA",IBCCV=$O(^PRCA(430.2,"B",IBCCVN,0))
S IBCCSN="CHAMPVA SUBSISTENCE",IBCCS=$O(^PRCA(430.2,"B",IBCCSN,0))
;
S IBCTPD=$G(^PRCA(430.2,+IBCTP,0)) I IBCTPD="" S IBQ=1 W !," >> ACCOUNTS RECEIVABLE CATEGORY (430.2) '",IBCTPN,"' not found."
S IBCCVD=$G(^PRCA(430.2,+IBCCV,0)) I IBCCVD="" S IBQ=1 W !," >> ACCOUNTS RECEIVABLE CATEGORY (430.2) '",IBCCVN,"' not found."
S IBCCSD=$G(^PRCA(430.2,+IBCCS,0)) I IBCCSD="" S IBQ=1 W !," >> ACCOUNTS RECEIVABLE CATEGORY (430.2) '",IBCCSN,"' not found."
;
I IBQ D
.W !!,*7,"Patch PRCA*4*15 or PRCA*4.5*1 does not appear to be installed! Please install"
.W !,"the appropriate patch and then re-run this initialization."
;
K IBCTPN,IBCTPD,IBCCVN,IBCCVD,IBCCSN,IBCCSD
Q
;
CHKIB ; Make sure IB parameters exist and haven't been modified.
S IBRTPN="CHAMPVA REIMB. INS.",IBRTP=$O(^DGCR(399.3,"B",IBRTPN,0))
S IBRCVN="CHAMPVA",IBRCV=$O(^DGCR(399.3,"B",IBRCVN,0))
;
S IBACNN="DG CHAMPVA PER DIEM NEW",IBACN=$O(^IBE(350.1,"B",IBACNN,0))
S IBACCN="DG CHAMPVA PER DIEM CANCEL",IBACC=$O(^IBE(350.1,"B",IBACCN,0))
S IBACUN="DG CHAMPVA PER DIEM UPDATE",IBACU=$O(^IBE(350.1,"B",IBACUN,0))
;
S IBRTPD=$G(^DGCR(399.3,+IBRTP,0)) I IBRTPD="" S IBQ=1 W !," >> RATE TYPE (399.3) '",IBRTPN,"' not found."
S IBRCVD=$G(^DGCR(399.3,+IBRCV,0)) I IBRCVD="" S IBQ=1 W !," >> RATE TYPE (399.3) '",IBRCVN,"' not found."
S IBACND=$G(^IBE(350.1,+IBACN,0)) I IBACND="" S IBQ=1 W !," >> ACTION TYPE (350.1) '",IBACNN,"' not found."
S IBACCD=$G(^IBE(350.1,+IBACC,0)) I IBACCD="" S IBQ=1 W !," >> ACTION TYPE (350.1) '",IBACCN,"' not found."
S IBACUD=$G(^IBE(350.1,+IBACU,0)) I IBACUD="" S IBQ=1 W !," >> ACTION TYPE (350.1) '",IBACUN,"' not found."
I IBQ D G CHKIBQ
.W !!,"Required file entries are missing. You should determine why you do not"
.W !,"have these entries before continuing. They should have been installed"
.W !,"with the installation of IB v2.0."
;
; check that Rate Types have not been modified since release of IB v2.0
I '$P(IBRTPD,U,3) S IBQ=1 W !!," >> RATE TYPE (399.3) '",IBRTPN,"' is not Inactive."
I +$P(IBRTPD,U,6) D
.W !!," >> RATE TYPE (399.3) '",IBRTPN,"' already has a pointer"
.W !," to an ACCOUNTS RECEIVABLE CATEGORY (430.2)."
.W !," This RATE TYPE will be re-pointed to a new CATEGORY in this installation."
;
I '$P(IBRCVD,U,3) S IBQ=1 W !!," >> RATE TYPE (399.3) '",IBRCVN,"' is not Inactive."
I +$P(IBRCVD,U,6) D
.W !!," >> RATE TYPE (399.3) '",IBRCVN,"' already has a pointer"
.W !," to an ACCOUNTS RECEIVABLE CATEGORY (430.2)."
.W !," This RATE TYPE will be re-pointed to a new CATEGORY in this installation."
;
I IBQ D
.W !!,"RATE TYPE entries have changed since the release of IB 2.0. You should"
.W !,"determine why these entries may have changed, and then inactivate"
.W !,"the Rate Types again, before re-running the initialization."
;
CHKIBQ K IBRTPN,IBRTPD,IBRCVN,IBRCVD,IBACNN,IBACND,IBACCN,IBACCD,IBACUN,IBACUD
Q
;
;
RERUN() ; Has the installation already been run?
N X,Y,Z S (X,Y,Z)=0
F S X=$O(^IBE(350.2,"B","CHAMPVA PER DIEM",X)) Q:'X S Y=X
I Y S Y=$G(^IBE(350.2,Y,0)) I $P(Y,"^",2)=2941001,+$P(Y,"^",4)=9.5 S Z=1
Q Z
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBYBPRE 4198 printed Sep 23, 2025@20:12:03 Page 2
IBYBPRE ;ALB/ARH - PATCH IB*2*27 ENVIRONMENT CHECK ; 10-FEB-95
+1 ;;Version 2.0 ; INTEGRATED BILLING ;**27**; 21-MAR-94
+2 ;
EN ; Perform checks to be sure IB*2*27 can be installed.
+1 ;
+2 WRITE !
SET IBQ=0
+3 ;
+4 ; check DUZ and DUZ(0)
DO CHKUSR
IF IBQ
GOTO ENQ
+5 ;
+6 ; skip checks if it appears init is being re-run
IF $$RERUN()
GOTO ENQ
+7 ;
+8 ; make sure patch PRCA*4*15 or PRCA*4.5*1 is installed
DO CHKAR
+9 ; make sure IB parameters are in place
DO CHKIB
+10 ;
+11 ; stop the install if there is a problem
IF IBQ
KILL DIFQ
+12 ;
ENQ KILL IBQ
+1 QUIT
+2 ;
+3 ;
CHKUSR ; Check DUZ and DUZ(0).
+1 IF $SELECT('($DATA(DUZ)#2):1,'$DATA(^VA(200,+DUZ,0)):1,'$DATA(DUZ(0)):1,1:0)
Begin DoDot:1
+2 WRITE !!?3,"The variable DUZ must be set to an active user code and the variable"
+3 WRITE !?3,"DUZ(0) must also be defined to run this initialization.",!
+4 KILL DIFQ
SET IBQ=1
End DoDot:1
+5 QUIT
+6 ;
CHKAR ; Make sure patch PRCA*4*15 or PRCA*4.5*1 is properly installed.
+1 SET IBCTPN="CHAMPVA THIRD PARTY"
SET IBCTP=$ORDER(^PRCA(430.2,"B",IBCTPN,0))
+2 SET IBCCVN="CHAMPVA"
SET IBCCV=$ORDER(^PRCA(430.2,"B",IBCCVN,0))
+3 SET IBCCSN="CHAMPVA SUBSISTENCE"
SET IBCCS=$ORDER(^PRCA(430.2,"B",IBCCSN,0))
+4 ;
+5 SET IBCTPD=$GET(^PRCA(430.2,+IBCTP,0))
IF IBCTPD=""
SET IBQ=1
WRITE !," >> ACCOUNTS RECEIVABLE CATEGORY (430.2) '",IBCTPN,"' not found."
+6 SET IBCCVD=$GET(^PRCA(430.2,+IBCCV,0))
IF IBCCVD=""
SET IBQ=1
WRITE !," >> ACCOUNTS RECEIVABLE CATEGORY (430.2) '",IBCCVN,"' not found."
+7 SET IBCCSD=$GET(^PRCA(430.2,+IBCCS,0))
IF IBCCSD=""
SET IBQ=1
WRITE !," >> ACCOUNTS RECEIVABLE CATEGORY (430.2) '",IBCCSN,"' not found."
+8 ;
+9 IF IBQ
Begin DoDot:1
+10 WRITE !!,*7,"Patch PRCA*4*15 or PRCA*4.5*1 does not appear to be installed! Please install"
+11 WRITE !,"the appropriate patch and then re-run this initialization."
End DoDot:1
+12 ;
+13 KILL IBCTPN,IBCTPD,IBCCVN,IBCCVD,IBCCSN,IBCCSD
+14 QUIT
+15 ;
CHKIB ; Make sure IB parameters exist and haven't been modified.
+1 SET IBRTPN="CHAMPVA REIMB. INS."
SET IBRTP=$ORDER(^DGCR(399.3,"B",IBRTPN,0))
+2 SET IBRCVN="CHAMPVA"
SET IBRCV=$ORDER(^DGCR(399.3,"B",IBRCVN,0))
+3 ;
+4 SET IBACNN="DG CHAMPVA PER DIEM NEW"
SET IBACN=$ORDER(^IBE(350.1,"B",IBACNN,0))
+5 SET IBACCN="DG CHAMPVA PER DIEM CANCEL"
SET IBACC=$ORDER(^IBE(350.1,"B",IBACCN,0))
+6 SET IBACUN="DG CHAMPVA PER DIEM UPDATE"
SET IBACU=$ORDER(^IBE(350.1,"B",IBACUN,0))
+7 ;
+8 SET IBRTPD=$GET(^DGCR(399.3,+IBRTP,0))
IF IBRTPD=""
SET IBQ=1
WRITE !," >> RATE TYPE (399.3) '",IBRTPN,"' not found."
+9 SET IBRCVD=$GET(^DGCR(399.3,+IBRCV,0))
IF IBRCVD=""
SET IBQ=1
WRITE !," >> RATE TYPE (399.3) '",IBRCVN,"' not found."
+10 SET IBACND=$GET(^IBE(350.1,+IBACN,0))
IF IBACND=""
SET IBQ=1
WRITE !," >> ACTION TYPE (350.1) '",IBACNN,"' not found."
+11 SET IBACCD=$GET(^IBE(350.1,+IBACC,0))
IF IBACCD=""
SET IBQ=1
WRITE !," >> ACTION TYPE (350.1) '",IBACCN,"' not found."
+12 SET IBACUD=$GET(^IBE(350.1,+IBACU,0))
IF IBACUD=""
SET IBQ=1
WRITE !," >> ACTION TYPE (350.1) '",IBACUN,"' not found."
+13 IF IBQ
Begin DoDot:1
+14 WRITE !!,"Required file entries are missing. You should determine why you do not"
+15 WRITE !,"have these entries before continuing. They should have been installed"
+16 WRITE !,"with the installation of IB v2.0."
End DoDot:1
GOTO CHKIBQ
+17 ;
+18 ; check that Rate Types have not been modified since release of IB v2.0
+19 IF '$PIECE(IBRTPD,U,3)
SET IBQ=1
WRITE !!," >> RATE TYPE (399.3) '",IBRTPN,"' is not Inactive."
+20 IF +$PIECE(IBRTPD,U,6)
Begin DoDot:1
+21 WRITE !!," >> RATE TYPE (399.3) '",IBRTPN,"' already has a pointer"
+22 WRITE !," to an ACCOUNTS RECEIVABLE CATEGORY (430.2)."
+23 WRITE !," This RATE TYPE will be re-pointed to a new CATEGORY in this installation."
End DoDot:1
+24 ;
+25 IF '$PIECE(IBRCVD,U,3)
SET IBQ=1
WRITE !!," >> RATE TYPE (399.3) '",IBRCVN,"' is not Inactive."
+26 IF +$PIECE(IBRCVD,U,6)
Begin DoDot:1
+27 WRITE !!," >> RATE TYPE (399.3) '",IBRCVN,"' already has a pointer"
+28 WRITE !," to an ACCOUNTS RECEIVABLE CATEGORY (430.2)."
+29 WRITE !," This RATE TYPE will be re-pointed to a new CATEGORY in this installation."
End DoDot:1
+30 ;
+31 IF IBQ
Begin DoDot:1
+32 WRITE !!,"RATE TYPE entries have changed since the release of IB 2.0. You should"
+33 WRITE !,"determine why these entries may have changed, and then inactivate"
+34 WRITE !,"the Rate Types again, before re-running the initialization."
End DoDot:1
+35 ;
CHKIBQ KILL IBRTPN,IBRTPD,IBRCVN,IBRCVD,IBACNN,IBACND,IBACCN,IBACCD,IBACUN,IBACUD
+1 QUIT
+2 ;
+3 ;
RERUN() ; Has the installation already been run?
+1 NEW X,Y,Z
SET (X,Y,Z)=0
+2 FOR
SET X=$ORDER(^IBE(350.2,"B","CHAMPVA PER DIEM",X))
if 'X
QUIT
SET Y=X
+3 IF Y
SET Y=$GET(^IBE(350.2,Y,0))
IF $PIECE(Y,"^",2)=2941001
IF +$PIECE(Y,"^",4)=9.5
SET Z=1
+4 QUIT Z
