Routine: IBYPPG

IBYPPG ;ALB/ARH - IB*2*148 POST INIT: REASONABLE CHARGES V1.2 ; 05/17/01

 ;;2.0;INTEGRATED BILLING;**148**;21-MAR-94

POST ;

 N IBA

 S IBA(1)="",IBA(2)="    IB*2*148 Post-Install .....",IBA(3)="" D MES^XPDUTL(.IBA) K IBA

 D CPTINA ; inactivate charges for inactive CPT codes

 D CSEMPTY ; delete Charge Sets with no charges assigned

 D ERRORCD ; add error code IB320 to IB Error file (#350.8)

 S IBA(1)="",IBA(2)="    IB*2*148 Post-Install Complete",IBA(3)="" D MES^XPDUTL(.IBA) K IBA

CPTINA ; inactivate charges for Inactive CPTs

 N IBA,IBCNT S IBCNT=0

 S IBA(1)="",IBA(2)="    >> Inactivating Charges for Inactive CPT codes, Please Wait..." D MES^XPDUTL(.IBA) K IBA

 S IBCNT=$$INACTCPT^IBCREC(0) ; inactivate charges for inactive CPT codes

 S IBA(1)="       Done.  "_IBCNT_" Charges Inactivated." D MES^XPDUTL(.IBA) K IBA

CSEMPTY ; delete Charges Sets with no Charges assigned

 N IBA,IBCNT S IBCNT=0

 S IBA(1)="",IBA(2)="    >> Removing Charges Sets that have no Charges Assigned..." D MES^XPDUTL(.IBA) K IBA

 S IBCNT=$$CSEMPTY^IBCRED() ; delete Charge Sets that have no charges

 S IBA(1)="       Done.  "_IBCNT_" Charges Sets Removed." D MES^XPDUTL(.IBA) K IBA

ERRORCD ; add a new Error Code to #350.8

 N IBA,IBCODE,IBEMES,IBFN,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y

 S IBCODE="IB320",IBEMES="Clinic Required for Surgical Procedures (10000-69999, 93501-93533)"

 I $O(^IBE(350.8,"AC",IBCODE,0)) Q

 K DD,DO S DLAYGO=350.8,DIC="^IBE(350.8,",DIC(0)="L",X=IBCODE D FILE^DICN K DIC I Y<1 K X,Y Q

 S IBFN=+Y

 S DR=".02///"_IBEMES_";.03///"_IBCODE_";.04////1;.05////1"

 S DIE="^IBE(350.8,",DA=+IBFN D ^DIE K DIE,DA,DR,X,Y

 S IBA(1)="",IBA(2)="    >> Error Code IB320 Added to IB Error File (#350.8) " D MES^XPDUTL(.IBA) K IBA

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBYPPG   1828     printed  Mar 13, 2025@21:41:40                                                                                                                                                                                                      Page 2

IBYPPG    ;ALB/ARH - IB*2*148 POST INIT: REASONABLE CHARGES V1.2 ; 05/17/01

 +1       ;;2.0;INTEGRATED BILLING;**148**;21-MAR-94

 +2       ;

 +3        QUIT

POST      ;

 +1        NEW IBA

 +2        SET IBA(1)=""

           SET IBA(2)="    IB*2*148 Post-Install ....."

           SET IBA(3)=""

           DO MES^XPDUTL(.IBA)

           KILL IBA

 +3       ;

 +4       ;

 +5       ; inactivate charges for inactive CPT codes

           DO CPTINA

 +6       ; delete Charge Sets with no charges assigned

           DO CSEMPTY

 +7       ; add error code IB320 to IB Error file (#350.8)

           DO ERRORCD

 +8       ;

 +9        SET IBA(1)=""

           SET IBA(2)="    IB*2*148 Post-Install Complete"

           SET IBA(3)=""

           DO MES^XPDUTL(.IBA)

           KILL IBA

 +10       QUIT

 +11      ;

 +12      ;

CPTINA    ; inactivate charges for Inactive CPTs

 +1        NEW IBA,IBCNT

           SET IBCNT=0

 +2        SET IBA(1)=""

           SET IBA(2)="    >> Inactivating Charges for Inactive CPT codes, Please Wait..."

           DO MES^XPDUTL(.IBA)

           KILL IBA

 +3       ;

 +4       ; inactivate charges for inactive CPT codes

           SET IBCNT=$$INACTCPT^IBCREC(0)

 +5       ;

 +6        SET IBA(1)="       Done.  "_IBCNT_" Charges Inactivated."

           DO MES^XPDUTL(.IBA)

           KILL IBA

 +7        QUIT

 +8       ;

CSEMPTY   ; delete Charges Sets with no Charges assigned

 +1        NEW IBA,IBCNT

           SET IBCNT=0

 +2        SET IBA(1)=""

           SET IBA(2)="    >> Removing Charges Sets that have no Charges Assigned..."

           DO MES^XPDUTL(.IBA)

           KILL IBA

 +3       ;

 +4       ; delete Charge Sets that have no charges

           SET IBCNT=$$CSEMPTY^IBCRED()

 +5       ;

 +6        SET IBA(1)="       Done.  "_IBCNT_" Charges Sets Removed."

           DO MES^XPDUTL(.IBA)

           KILL IBA

 +7        QUIT

 +8       ;

ERRORCD   ; add a new Error Code to #350.8

 +1        NEW IBA,IBCODE,IBEMES,IBFN,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y

 +2       ;

 +3        SET IBCODE="IB320"

           SET IBEMES="Clinic Required for Surgical Procedures (10000-69999, 93501-93533)"

 +4       ;

 +5        IF $ORDER(^IBE(350.8,"AC",IBCODE,0))

               QUIT

 +6       ;

 +7        KILL DD,DO

           SET DLAYGO=350.8

           SET DIC="^IBE(350.8,"

           SET DIC(0)="L"

           SET X=IBCODE

           DO FILE^DICN

           KILL DIC

           IF Y<1

               KILL X,Y

               QUIT

 +8        SET IBFN=+Y

 +9       ;

 +10       SET DR=".02///"_IBEMES_";.03///"_IBCODE_";.04////1;.05////1"

 +11       SET DIE="^IBE(350.8,"

           SET DA=+IBFN

           DO ^DIE

           KILL DIE,DA,DR,X,Y

 +12      ;

 +13       SET IBA(1)=""

           SET IBA(2)="    >> Error Code IB320 Added to IB Error File (#350.8) "

           DO MES^XPDUTL(.IBA)

           KILL IBA

 +14       QUIT

IBYPPG.m