IB2P187A ;WOIFO/SS-VISIT COPAY PHASE 2 IB*2.0*187 POST INIT ;19-AUG-02
;;2.0;INTEGRATED BILLING;**187**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
POST ;
N X,Y
F X="START","F6DIG","FADD","FUPD","FNON","FSPEC","FBASIC","ED36321","FINISH" S Y=$$NEWCP^XPDUTL(X,X_"^IB2P187A")
;
; F6DIG - add 6 digits codes to file 352.5
; FADD - add additional 3 digit codes to file 352.5
; FUPD - add updates for 3 digit codes to file 352.5
; FNON - NON BILLABLE entries for override table in 352.5
; FSPEC - SPECIALTY entries for override table in 352.5
; FBASIC - BASIC entries for override table in 352.5
; ED36321 - change PRIMARY to BASIC in 363.21
;
Q
START ;
N IBA
S IBA(1)=""
S IBA(2)=" Visit Copay Phase II, Post-Install Starting",IBA(3)=""
S IBA(7)=""
D MES^XPDUTL(.IBA)
Q
;
FINISH ;
N IBA
S IBA(1)=""
S IBA(2)=" Visit Copay Phase II, Post-Install Complete"
D MES^XPDUTL(.IBA)
Q
;
;
F6DIG ; add entries in file 352.5 (if not there)
;
D FILEIT("F6DIG")
Q
;
FADD ; add entries in file 352.5 (if not there)
;
D FILEIT("FADD")
Q
;
FUPD ; add entries in file 352.5 (if not there)
;
D FILEIT("FUPD")
Q
FNON ; add entries in file 352.5 (if not there) from NON-BILLABLE override table
;
D FILEIT("FNON")
Q
;
FSPEC ; add entries in file 352.5 (if not there) from SPECIALTY override table
;
D FILEIT("FSPEC")
Q
;
FBASIC ; add entries in file 352.5 (if not there) from BASIC override table
;
D FILEIT("FBASIC")
Q
;
FILEIT(IBOPER) ;
;
N DIC,X,Y,IBC,IBX,DO,IBT,DA,IBA,DIK,IBS,IB3501,IBP,IBY
S:IBOPER="F6DIG" IBA(2)=" Now adding the 6 digit override codes to file 352.5"
S:IBOPER="FADD" IBA(2)=" Now adding additional 3 digit codes to file 352.5"
S:IBOPER="FUPD" IBA(2)=" Now adding updates for 3 digit codes to file 352.5"
S:IBOPER="FNON" IBA(2)=" Now adding entries of NON-BILLABLE override table to file 352.5"
S:IBOPER="FSPEC" IBA(2)=" Now adding entries of SPECIALTY override table to file 352.5"
S:IBOPER="FBASIC" IBA(2)=" Now adding entries of BASIC override table to file 352.5"
S (IBA(1),IBA(3))="" D MES^XPDUTL(.IBA) K IBA
I $$PATCH^XPDUTL("IB*2.0*187") D BMES^XPDUTL(" Skipping since the patch was previously installed.") Q
S IBC=0
I IBOPER="F6DIG" F IBX=1:1 S IBT=$P($T(D6DIG+IBX^IB2P187B),";",3) Q:'$L(IBT) S Y=+$$INS3525(IBT,3021001,1) S:Y>0 IBC=IBC+1
I IBOPER="FADD" F IBX=1:1 S IBT=$P($T(DADD+IBX^IB2P187B),";",3) Q:'$L(IBT) S Y=+$$INS3525(IBT,3021001,0) S:Y>0 IBC=IBC+1
I IBOPER="FUPD" F IBX=1:1 S IBT=$P($T(DUPD+IBX^IB2P187B),";",3) Q:'$L(IBT) S Y=+$$INS3525(IBT,3021001,0) S:Y>0 IBC=IBC+1
I IBOPER="FNON" F IBX=1:1 S IBT=$P($T(DNON+IBX^IB2P187B),";",3) Q:'$L(IBT) S Y=+$$INS3525(IBT,3021001,1) S:Y>0 IBC=IBC+1
I IBOPER="FSPEC" F IBX=1:1 S IBT=$P($T(DSPEC+IBX^IB2P187B),";",3) Q:'$L(IBT) S Y=+$$INS3525(IBT,3021001,1) S:Y>0 IBC=IBC+1
I IBOPER="FBASIC" F IBX=1:1 S IBT=$P($T(DBASIC+IBX^IB2P187B),";",3) Q:'$L(IBT) S Y=+$$INS3525(IBT,3021001,1) S:Y>0 IBC=IBC+1
S IBA(2)=" "_IBC_" entries added to 352.5"
S (IBA(1),IBA(3))="",IBC=0
D MES^XPDUTL(.IBA) K IBA
Q
;
;IBDATA: data for #352.5 entries
;IBEFFDT: effective date
;IBOVER: 1 if we are adding code from override table, otherwise - 0
INS3525(IBDATA,IBEFFDT,IBOVER) ;
N IBIENS,IBFDA,IBER,IBRET,IBSEEKDT,IBLSTDT,IBOFL,IB1
S IBSEEKDT=IBEFFDT+0.0001
S IBRET=""
N IBTYPE S IBTYPE=$P(IBDATA,"^",3),IBTYPE=$P(IBTYPE," ") ;bill type
S IBTYPE=$S(IBTYPE="S":2,IBTYPE="B":1,1:0)
S IBLSTDT=-$O(^IBE(352.5,"AEFFDT",+$P(IBDATA,"^",1),-IBSEEKDT))
I IBOVER=0 I IBLSTDT=IBEFFDT D BMES^XPDUTL(" Duplication of non-override code "_$P(IBDATA,"^",1)) Q 0
I IBOVER=1 I IBLSTDT=IBEFFDT D I IBOFL=1 Q 0
. S IBOFL=0
. S IB1=+$O(^IBE(352.5,"AEFFDT",+$P(IBDATA,"^",1),-IBEFFDT,0))
. Q:IB1=0 ;error - need to add a new entry
. S IBOFL=+$P($G(^IBE(352.5,IB1,0)),"^",5)
. I IBOFL=1 D BMES^XPDUTL(" Duplication of override code "_$P(IBDATA,"^",1)) Q
. S IBIENS=IB1_","
. S IBFDA(352.5,IBIENS,.03)=IBTYPE
. S IBFDA(352.5,IBIENS,.04)=$P(IBDATA,"^",2)
. S IBFDA(352.5,IBIENS,.05)=1
. D FILE^DIE("","IBFDA","IBERR")
. S IBOFL=1 D BMES^XPDUTL(" Update of override code "_$P(IBDATA,"^",1))
;
S IBIENS="+1,"
S IBFDA(352.5,IBIENS,.01)=$P(IBDATA,"^",1)
S IBFDA(352.5,IBIENS,.02)=IBEFFDT
S IBFDA(352.5,IBIENS,.03)=IBTYPE
S IBFDA(352.5,IBIENS,.04)=$P(IBDATA,"^",2)
I IBOVER=1 S IBFDA(352.5,IBIENS,.05)=1
D UPDATE^DIE("","IBFDA","IBRET","IBER")
I $D(IBER) D BMES^XPDUTL(IBER("DIERR",1,"TEXT",1))
Q $G(IBRET(1))
;
ED36321 ;change PRIMARY CARE to BASIC CARE
N IBA
S IBA(2)=" Now changing PRIMARY CARE to BASIC CARE in file #363.21"
S (IBA(1),IBA(3))="" D MES^XPDUTL(.IBA)
N IBIENCL
S IBIENCL=$O(^IBA(363.21,"B","PRIMARY CARE",0))
Q:+IBIENCL=0
N IBIENS,IBFDA,IBERR
S IBIENS=IBIENCL_"," ; "D0,"
S IBFDA(363.21,IBIENS,.01)="BASIC CARE"
D FILE^DIE("","IBFDA","IBERR")
I $D(IBER) D BMES^XPDUTL(IBER("DIERR",1,"TEXT",1))
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB2P187A 5032 printed Sep 23, 2025@19:41:53 Page 2
IB2P187A ;WOIFO/SS-VISIT COPAY PHASE 2 IB*2.0*187 POST INIT ;19-AUG-02
+1 ;;2.0;INTEGRATED BILLING;**187**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
POST ;
+1 NEW X,Y
+2 FOR X="START","F6DIG","FADD","FUPD","FNON","FSPEC","FBASIC","ED36321","FINISH"
SET Y=$$NEWCP^XPDUTL(X,X_"^IB2P187A")
+3 ;
+4 ; F6DIG - add 6 digits codes to file 352.5
+5 ; FADD - add additional 3 digit codes to file 352.5
+6 ; FUPD - add updates for 3 digit codes to file 352.5
+7 ; FNON - NON BILLABLE entries for override table in 352.5
+8 ; FSPEC - SPECIALTY entries for override table in 352.5
+9 ; FBASIC - BASIC entries for override table in 352.5
+10 ; ED36321 - change PRIMARY to BASIC in 363.21
+11 ;
+12 QUIT
START ;
+1 NEW IBA
+2 SET IBA(1)=""
+3 SET IBA(2)=" Visit Copay Phase II, Post-Install Starting"
SET IBA(3)=""
+4 SET IBA(7)=""
+5 DO MES^XPDUTL(.IBA)
+6 QUIT
+7 ;
FINISH ;
+1 NEW IBA
+2 SET IBA(1)=""
+3 SET IBA(2)=" Visit Copay Phase II, Post-Install Complete"
+4 DO MES^XPDUTL(.IBA)
+5 QUIT
+6 ;
+7 ;
F6DIG ; add entries in file 352.5 (if not there)
+1 ;
+2 DO FILEIT("F6DIG")
+3 QUIT
+4 ;
FADD ; add entries in file 352.5 (if not there)
+1 ;
+2 DO FILEIT("FADD")
+3 QUIT
+4 ;
FUPD ; add entries in file 352.5 (if not there)
+1 ;
+2 DO FILEIT("FUPD")
+3 QUIT
FNON ; add entries in file 352.5 (if not there) from NON-BILLABLE override table
+1 ;
+2 DO FILEIT("FNON")
+3 QUIT
+4 ;
FSPEC ; add entries in file 352.5 (if not there) from SPECIALTY override table
+1 ;
+2 DO FILEIT("FSPEC")
+3 QUIT
+4 ;
FBASIC ; add entries in file 352.5 (if not there) from BASIC override table
+1 ;
+2 DO FILEIT("FBASIC")
+3 QUIT
+4 ;
FILEIT(IBOPER) ;
+1 ;
+2 NEW DIC,X,Y,IBC,IBX,DO,IBT,DA,IBA,DIK,IBS,IB3501,IBP,IBY
+3 if IBOPER="F6DIG"
SET IBA(2)=" Now adding the 6 digit override codes to file 352.5"
+4 if IBOPER="FADD"
SET IBA(2)=" Now adding additional 3 digit codes to file 352.5"
+5 if IBOPER="FUPD"
SET IBA(2)=" Now adding updates for 3 digit codes to file 352.5"
+6 if IBOPER="FNON"
SET IBA(2)=" Now adding entries of NON-BILLABLE override table to file 352.5"
+7 if IBOPER="FSPEC"
SET IBA(2)=" Now adding entries of SPECIALTY override table to file 352.5"
+8 if IBOPER="FBASIC"
SET IBA(2)=" Now adding entries of BASIC override table to file 352.5"
+9 SET (IBA(1),IBA(3))=""
DO MES^XPDUTL(.IBA)
KILL IBA
+10 IF $$PATCH^XPDUTL("IB*2.0*187")
DO BMES^XPDUTL(" Skipping since the patch was previously installed.")
QUIT
+11 SET IBC=0
+12 IF IBOPER="F6DIG"
FOR IBX=1:1
SET IBT=$PIECE($TEXT(D6DIG+IBX^IB2P187B),";",3)
if '$LENGTH(IBT)
QUIT
SET Y=+$$INS3525(IBT,3021001,1)
if Y>0
SET IBC=IBC+1
+13 IF IBOPER="FADD"
FOR IBX=1:1
SET IBT=$PIECE($TEXT(DADD+IBX^IB2P187B),";",3)
if '$LENGTH(IBT)
QUIT
SET Y=+$$INS3525(IBT,3021001,0)
if Y>0
SET IBC=IBC+1
+14 IF IBOPER="FUPD"
FOR IBX=1:1
SET IBT=$PIECE($TEXT(DUPD+IBX^IB2P187B),";",3)
if '$LENGTH(IBT)
QUIT
SET Y=+$$INS3525(IBT,3021001,0)
if Y>0
SET IBC=IBC+1
+15 IF IBOPER="FNON"
FOR IBX=1:1
SET IBT=$PIECE($TEXT(DNON+IBX^IB2P187B),";",3)
if '$LENGTH(IBT)
QUIT
SET Y=+$$INS3525(IBT,3021001,1)
if Y>0
SET IBC=IBC+1
+16 IF IBOPER="FSPEC"
FOR IBX=1:1
SET IBT=$PIECE($TEXT(DSPEC+IBX^IB2P187B),";",3)
if '$LENGTH(IBT)
QUIT
SET Y=+$$INS3525(IBT,3021001,1)
if Y>0
SET IBC=IBC+1
+17 IF IBOPER="FBASIC"
FOR IBX=1:1
SET IBT=$PIECE($TEXT(DBASIC+IBX^IB2P187B),";",3)
if '$LENGTH(IBT)
QUIT
SET Y=+$$INS3525(IBT,3021001,1)
if Y>0
SET IBC=IBC+1
+18 SET IBA(2)=" "_IBC_" entries added to 352.5"
+19 SET (IBA(1),IBA(3))=""
SET IBC=0
+20 DO MES^XPDUTL(.IBA)
KILL IBA
+21 QUIT
+22 ;
+23 ;IBDATA: data for #352.5 entries
+24 ;IBEFFDT: effective date
+25 ;IBOVER: 1 if we are adding code from override table, otherwise - 0
INS3525(IBDATA,IBEFFDT,IBOVER) ;
+1 NEW IBIENS,IBFDA,IBER,IBRET,IBSEEKDT,IBLSTDT,IBOFL,IB1
+2 SET IBSEEKDT=IBEFFDT+0.0001
+3 SET IBRET=""
+4 ;bill type
NEW IBTYPE
SET IBTYPE=$PIECE(IBDATA,"^",3)
SET IBTYPE=$PIECE(IBTYPE," ")
+5 SET IBTYPE=$SELECT(IBTYPE="S":2,IBTYPE="B":1,1:0)
+6 SET IBLSTDT=-$ORDER(^IBE(352.5,"AEFFDT",+$PIECE(IBDATA,"^",1),-IBSEEKDT))
+7 IF IBOVER=0
IF IBLSTDT=IBEFFDT
DO BMES^XPDUTL(" Duplication of non-override code "_$PIECE(IBDATA,"^",1))
QUIT 0
+8 IF IBOVER=1
IF IBLSTDT=IBEFFDT
Begin DoDot:1
+9 SET IBOFL=0
+10 SET IB1=+$ORDER(^IBE(352.5,"AEFFDT",+$PIECE(IBDATA,"^",1),-IBEFFDT,0))
+11 ;error - need to add a new entry
if IB1=0
QUIT
+12 SET IBOFL=+$PIECE($GET(^IBE(352.5,IB1,0)),"^",5)
+13 IF IBOFL=1
DO BMES^XPDUTL(" Duplication of override code "_$PIECE(IBDATA,"^",1))
QUIT
+14 SET IBIENS=IB1_","
+15 SET IBFDA(352.5,IBIENS,.03)=IBTYPE
+16 SET IBFDA(352.5,IBIENS,.04)=$PIECE(IBDATA,"^",2)
+17 SET IBFDA(352.5,IBIENS,.05)=1
+18 DO FILE^DIE("","IBFDA","IBERR")
+19 SET IBOFL=1
DO BMES^XPDUTL(" Update of override code "_$PIECE(IBDATA,"^",1))
End DoDot:1
IF IBOFL=1
QUIT 0
+20 ;
+21 SET IBIENS="+1,"
+22 SET IBFDA(352.5,IBIENS,.01)=$PIECE(IBDATA,"^",1)
+23 SET IBFDA(352.5,IBIENS,.02)=IBEFFDT
+24 SET IBFDA(352.5,IBIENS,.03)=IBTYPE
+25 SET IBFDA(352.5,IBIENS,.04)=$PIECE(IBDATA,"^",2)
+26 IF IBOVER=1
SET IBFDA(352.5,IBIENS,.05)=1
+27 DO UPDATE^DIE("","IBFDA","IBRET","IBER")
+28 IF $DATA(IBER)
DO BMES^XPDUTL(IBER("DIERR",1,"TEXT",1))
+29 QUIT $GET(IBRET(1))
+30 ;
ED36321 ;change PRIMARY CARE to BASIC CARE
+1 NEW IBA
+2 SET IBA(2)=" Now changing PRIMARY CARE to BASIC CARE in file #363.21"
+3 SET (IBA(1),IBA(3))=""
DO MES^XPDUTL(.IBA)
+4 NEW IBIENCL
+5 SET IBIENCL=$ORDER(^IBA(363.21,"B","PRIMARY CARE",0))
+6 if +IBIENCL=0
QUIT
+7 NEW IBIENS,IBFDA,IBERR
+8 ; "D0,"
SET IBIENS=IBIENCL_","
+9 SET IBFDA(363.21,IBIENS,.01)="BASIC CARE"
+10 DO FILE^DIE("","IBFDA","IBERR")
+11 IF $DATA(IBER)
DO BMES^XPDUTL(IBER("DIERR",1,"TEXT",1))
+12 QUIT
+13 ;
