Routine: IBYPPT

IBYPPT ;ALB/ARH - IB*2*134 POST INIT: UPDATE PROVIDER DISCOUNT AND REVENUE CODES AND CONDITION CODES ; 05/25/00

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

POST ;

 N IBA

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

 D CCE ; update condition codes, 1

 D CCA ; add condition codes, 2

 D RVN ; add revenue codes, 2

 D PDDEL^IBYPPT1 ; delete all Provider Discount Sets and Links (363.34) for RC PROVIDER DISCOUNTS Special Group

 D PDADD^IBYPPT1 ; add new Provider Discount Sets and Links (363.34) for RC PROVIDER DISCOUNTS Special Group

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

RVN ; add 2 new Revenue Codes (399.2)

 ; (update abbreviation and description to match current NUBC, previously all reserved)

 N IBA,IBLN,IBI,IBRV,IBRVFN,IBCNG,IBCNT,IBJ,DD,DO,DIC,DIE,DA,DR,X,Y S IBCNT=0,IBCNG=""

 F IBI=1:1 S IBLN=$P($T(FRVN+IBI),";;",2,999) Q:IBLN=""  D

. ;

 . S IBRV=$P(IBLN,U,1) Q:IBRV'?3N

 . S IBRVFN=$O(^DGCR(399.2,"B",IBRV,0)) Q:'IBRVFN

. ;

 . S IBCNT=IBCNT+1,IBCNG=IBCNG_IBRV_","

 . S DR="1///"_$P(IBLN,U,2)_";3///"_$P(IBLN,U,3),DIE="^DGCR(399.2,",DA=+IBRVFN D ^DIE K DIE,DIC,DA,DR,X,Y

 I IBCNT>0 S IBJ=0 F IBI=1:15 S IBJ=IBJ+15 S IBLN=$P(IBCNG,",",IBI,IBJ) Q:IBLN=""  D MSG("         "_IBLN)

RVNQ S IBA(1)="    >> "_IBCNT_" Revenue Codes added (399.2)..." D MSG(" ")

 D MES^XPDUTL(.IBA)

MSG(X) ;

 N IBX S IBX=$O(IBA(999999),-1) S:'IBX IBX=1 S IBX=IBX+1

 S IBA(IBX)=$G(X)

FRVN ; New Revenue Codes

 ;;951^ATHLETIC TRAINING^ATHLETIC TRAINING

 ;;952^KINESIOTHERAPY^KINESIOTHERAPY

;;

MCCRUTL(X,P) ; returns IFN of item in 399.1 if Code is found and piece P is true

 N IBX,IBY S IBY=""

 I $G(X)'="" S IBX=0 F  S IBX=$O(^DGCR(399.1,"C",X,IBX)) Q:'IBX  I $P($G(^DGCR(399.1,IBX,0)),U,+$G(P)) S IBY=IBX

 Q IBY

CCE ; Edit Condition Codes in 399.1 (#.22 - p15)  update Name field (.01)

 N DINUM,DLAYGO,DIC,DIE,DD,DO,DA,DR,X,Y,IBA,IBI,IBLN,IBCNT,IBJ,IBFN,IBDNM S IBCNT=0

 F IBI=1:1 S IBLN=$P($T(FCCE+IBI),";;",2) Q:IBLN=""  I $E(IBLN,1)'=" " D

. ;

 . S IBFN=$$MCCRUTL($P(IBLN,U,1),15) Q:'IBFN

. ;

 . S DR=".01////"_$P(IBLN,U,2)

 . S DIE="^DGCR(399.1,",DA=+IBFN D ^DIE K DIE,DA,DR,X,Y S IBCNT=IBCNT+1

CCEQ S IBA(1)="    >> "_IBCNT_" Condition Codes updated (399.1)"

 D MES^XPDUTL(.IBA)

CCA ; Add Condition Codes to 399.1 (#.22 - p15)

 ; due to the conversion the condition codes must have IFNs greater than 79

 N DINUM,DLAYGO,DIC,DIE,DD,DO,DA,DR,X,Y,IBA,IBI,IBLN,IBCNT,IBJ,IBFN,IBDNM S IBCNT=0

 S IBDNM=$O(^DGCR(399.1,200),-1) I IBDNM'>79 S IBDNM=79

 F IBI=1:1 S IBLN=$P($T(FCCA+IBI),";;",2) Q:IBLN=""  I $E(IBLN,1)'=" " D

. ;

 . I +$$MCCRUTL($P(IBLN,U,1),15) Q

. ;

 . F IBJ=1:1 S IBDNM=IBDNM+1 Q:'$D(^DGCR(399.1,IBDNM,0))

. ;

 . K DD,DO S DLAYGO=399.1,DINUM=IBDNM,DIC="^DGCR(399.1,",DIC(0)="L",X=$P(IBLN,U,2) D FILE^DICN K DIC I Y<1 K X,Y Q

 . S IBFN=+Y,IBCNT=IBCNT+1

. ;

 . S DR=".02////"_$P(IBLN,U,1)_";.22////"_1

 . S DIE="^DGCR(399.1,",DA=+IBFN D ^DIE K DIE,DA,DR,X,Y

CCAQ S IBA(1)="    >> "_IBCNT_" Condition Codes added (399.1)"

 D MES^XPDUTL(.IBA)

FCCA ; add condition codes (399.1)

;;

 ;;58^TERMINATED MEDICARE+CHOICE ORGANIZATION ENROLLEE

 ;;G0^DISTINCT MEDICAL VISIT

;;

FCCE ; edit condition codes (399.1)

;;

 ;;72^SELF CARE IN UNIT

;;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBYPPT   3439     printed  Mar 13, 2025@21:41:46                                                                                                                                                                                                      Page 2

IBYPPT    ;ALB/ARH - IB*2*134 POST INIT: UPDATE PROVIDER DISCOUNT AND REVENUE CODES AND CONDITION CODES ; 05/25/00

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

 +2       ;

 +3        QUIT

POST      ;

 +1        NEW IBA

 +2        SET IBA(1)=""

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

           SET IBA(3)=""

           DO MES^XPDUTL(.IBA)

           KILL IBA

 +3       ;

 +4       ; update condition codes, 1

           DO CCE

 +5       ; add condition codes, 2

           DO CCA

 +6       ; add revenue codes, 2

           DO RVN

 +7       ;

 +8       ; delete all Provider Discount Sets and Links (363.34) for RC PROVIDER DISCOUNTS Special Group

           DO PDDEL^IBYPPT1

 +9       ; add new Provider Discount Sets and Links (363.34) for RC PROVIDER DISCOUNTS Special Group

           DO PDADD^IBYPPT1

 +10      ;

 +11       SET IBA(1)=""

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

           SET IBA(3)=""

           DO MES^XPDUTL(.IBA)

           KILL IBA

 +12      ;

 +13       QUIT

 +14      ;

 +15      ;

RVN       ; add 2 new Revenue Codes (399.2)

 +1       ; (update abbreviation and description to match current NUBC, previously all reserved)

 +2        NEW IBA,IBLN,IBI,IBRV,IBRVFN,IBCNG,IBCNT,IBJ,DD,DO,DIC,DIE,DA,DR,X,Y

           SET IBCNT=0

           SET IBCNG=""

 +3       ;

 +4        FOR IBI=1:1

               SET IBLN=$PIECE($TEXT(FRVN+IBI),";;",2,999)

               if IBLN=""

                   QUIT

               Begin DoDot:1

 +5       ;

 +6                SET IBRV=$PIECE(IBLN,U,1)

                   if IBRV'?3N

                       QUIT

 +7                SET IBRVFN=$ORDER(^DGCR(399.2,"B",IBRV,0))

                   if 'IBRVFN

                       QUIT

 +8       ;

 +9                SET IBCNT=IBCNT+1

                   SET IBCNG=IBCNG_IBRV_","

 +10               SET DR="1///"_$PIECE(IBLN,U,2)_";3///"_$PIECE(IBLN,U,3)

                   SET DIE="^DGCR(399.2,"

                   SET DA=+IBRVFN

                   DO ^DIE

                   KILL DIE,DIC,DA,DR,X,Y

               End DoDot:1

 +11      ;

 +12       IF IBCNT>0

               SET IBJ=0

               FOR IBI=1:15

                   SET IBJ=IBJ+15

                   SET IBLN=$PIECE(IBCNG,",",IBI,IBJ)

                   if IBLN=""

                       QUIT

                   DO MSG("         "_IBLN)

 +13      ;

RVNQ       SET IBA(1)="    >> "_IBCNT_" Revenue Codes added (399.2)..."

           DO MSG(" ")

 +1        DO MES^XPDUTL(.IBA)

 +2        QUIT

 +3       ;

 +4       ;

MSG(X)    ;

 +1        NEW IBX

           SET IBX=$ORDER(IBA(999999),-1)

           if 'IBX

               SET IBX=1

           SET IBX=IBX+1

 +2        SET IBA(IBX)=$GET(X)

 +3        QUIT

 +4       ;

 +5       ;

FRVN      ; New Revenue Codes

 +1       ;;951^ATHLETIC TRAINING^ATHLETIC TRAINING

 +2       ;;952^KINESIOTHERAPY^KINESIOTHERAPY

 +3       ;;

 +4        QUIT

 +5       ;

MCCRUTL(X,P) ; returns IFN of item in 399.1 if Code is found and piece P is true

 +1       ;

 +2        NEW IBX,IBY

           SET IBY=""

 +3        IF $GET(X)'=""

               SET IBX=0

FOR

                   SET IBX=$ORDER(^DGCR(399.1,"C",X,IBX))

                   if 'IBX

                       QUIT

                   IF $PIECE($GET(^DGCR(399.1,IBX,0)),U,+$GET(P))

                       SET IBY=IBX

 +4        QUIT IBY

 +5       ;

CCE       ; Edit Condition Codes in 399.1 (#.22 - p15)  update Name field (.01)

 +1        NEW DINUM,DLAYGO,DIC,DIE,DD,DO,DA,DR,X,Y,IBA,IBI,IBLN,IBCNT,IBJ,IBFN,IBDNM

           SET IBCNT=0

 +2       ;

 +3        FOR IBI=1:1

               SET IBLN=$PIECE($TEXT(FCCE+IBI),";;",2)

               if IBLN=""

                   QUIT

               IF $EXTRACT(IBLN,1)'=" "

                   Begin DoDot:1

 +4       ;

 +5                    SET IBFN=$$MCCRUTL($PIECE(IBLN,U,1),15)

                       if 'IBFN

                           QUIT

 +6       ;

 +7                    SET DR=".01////"_$PIECE(IBLN,U,2)

 +8                    SET DIE="^DGCR(399.1,"

                       SET DA=+IBFN

                       DO ^DIE

                       KILL DIE,DA,DR,X,Y

                       SET IBCNT=IBCNT+1

                   End DoDot:1

 +9       ;

CCEQ       SET IBA(1)="    >> "_IBCNT_" Condition Codes updated (399.1)"

 +1        DO MES^XPDUTL(.IBA)

 +2        QUIT

 +3       ;

CCA       ; Add Condition Codes to 399.1 (#.22 - p15)

 +1       ; due to the conversion the condition codes must have IFNs greater than 79

 +2        NEW DINUM,DLAYGO,DIC,DIE,DD,DO,DA,DR,X,Y,IBA,IBI,IBLN,IBCNT,IBJ,IBFN,IBDNM

           SET IBCNT=0

 +3       ;

 +4        SET IBDNM=$ORDER(^DGCR(399.1,200),-1)

           IF IBDNM'>79

               SET IBDNM=79

 +5       ;

 +6        FOR IBI=1:1

               SET IBLN=$PIECE($TEXT(FCCA+IBI),";;",2)

               if IBLN=""

                   QUIT

               IF $EXTRACT(IBLN,1)'=" "

                   Begin DoDot:1

 +7       ;

 +8                    IF +$$MCCRUTL($PIECE(IBLN,U,1),15)

                           QUIT

 +9       ;

 +10                   FOR IBJ=1:1

                           SET IBDNM=IBDNM+1

                           if '$DATA(^DGCR(399.1,IBDNM,0))

                               QUIT

 +11      ;

 +12                   KILL DD,DO

                       SET DLAYGO=399.1

                       SET DINUM=IBDNM

                       SET DIC="^DGCR(399.1,"

                       SET DIC(0)="L"

                       SET X=$PIECE(IBLN,U,2)

                       DO FILE^DICN

                       KILL DIC

                       IF Y<1

                           KILL X,Y

                           QUIT

 +13                   SET IBFN=+Y

                       SET IBCNT=IBCNT+1

 +14      ;

 +15                   SET DR=".02////"_$PIECE(IBLN,U,1)_";.22////"_1

 +16                   SET DIE="^DGCR(399.1,"

                       SET DA=+IBFN

                       DO ^DIE

                       KILL DIE,DA,DR,X,Y

                   End DoDot:1

 +17      ;

CCAQ       SET IBA(1)="    >> "_IBCNT_" Condition Codes added (399.1)"

 +1        DO MES^XPDUTL(.IBA)

 +2        QUIT

 +3       ;

FCCA      ; add condition codes (399.1)

 +1       ;;

 +2       ;;58^TERMINATED MEDICARE+CHOICE ORGANIZATION ENROLLEE

 +3       ;;G0^DISTINCT MEDICAL VISIT

 +4       ;;

FCCE      ; edit condition codes (399.1)

 +1       ;;

 +2       ;;72^SELF CARE IN UNIT

 +3       ;;

IBYPPT.m