IB2P187A.m

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 ---IB2P187A   5032     printed  Apr 23, 2025@18:20:12                                                                                                                                                                                                    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      ;