IB20P354.m

IB20P354 ;BP/TJH-FY06 DSS CLINIC STOP CODES IB*2.0*354 PRE INIT ;29-JUN-06

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

 ;;Per VHA Directive 10-93-142, this routine should not be modified.

 ;

EN ;

 N IBEFFDT,U

 S U="^",IBEFFDT=3060401 ;effective date APR 1st, 2006 

 D START,ADD(IBEFFDT),FINISH

 Q

 ;

START D MES^XPDUTL("")

 D MES^XPDUTL("FY06 DSS Clinic Stop Codes Update Starting")

 Q

 ;

FINISH ;

 ; D MES^XPDUTL("")

 D MES^XPDUTL("FY06 DSS Clinic Stop Codes Update Complete")

 Q

 ;

MESS(IBSTR) ;

 N IBA

 S IBA(2)=IBSTR

 S (IBA(1),IBA(3))=""

 D MES^XPDUTL(.IBA)

 Q

 ;

ADD(IBEFFDT) ;

 ;add a new code

 N Y,IBC,IBT,IBX,IBCODE,IBTYPE,IBDES,IBOVER

 D MESS("  Adding new codes to file 352.5")

 S IBC=0

 F IBX=1:1 S IBT=$P($T(NCODE+IBX),";",3) Q:'$L(IBT)  D

 . S IBCODE=+$P(IBT,U)

 . I $D(^IBE(352.5,"AEFFDT",IBCODE,-IBEFFDT)) D  Q

 . . D MES^XPDUTL("  Duplication of non-billable type code "_IBCODE)

 . S IBTYPE=$P(IBT,U,2)

 . S IBDES=$E($P(IBT,U,3),1,30)

 . S IBOVER=$P(IBT,U,4)

 . S Y=+$$ADD3525(IBCODE,IBEFFDT,IBTYPE,IBDES,IBOVER) S:Y>0 IBC=IBC+1

 D MESS("     "_IBC_$S(IBC=1:" entry",1:" entries")_" added to 352.5")

 Q

 ;

 ;

ADD3525(IBCODE,IBEFFDT,IBTYPE,IBDES,IBOVER) ;

 ;add a new entry

 D MES^XPDUTL("   "_IBCODE_"  "_IBDES)

 N IBIENS,IBFDA,IBER,IBRET

 S IBRET=""

 S IBIENS="+1,"

 S IBFDA(352.5,IBIENS,.01)=IBCODE

 S IBFDA(352.5,IBIENS,.02)=IBEFFDT

 S IBFDA(352.5,IBIENS,.03)=IBTYPE

 S IBFDA(352.5,IBIENS,.04)=IBDES

 S:IBOVER IBFDA(352.5,IBIENS,.05)=1

 D UPDATE^DIE("","IBFDA","IBRET","IBER")

 I $D(IBER) D MES^XPDUTL(IBER("DIERR",1,"TEXT",1))

 Q $G(IBRET(1))

 ;

 ;new non-billable type data

NCODE ;;code^billable type^description^override flag

 ;;197^2^POLYTRAUMA INDIVIDUAL^1

 ;;198^2^POLYTRAUMA GROUP^1

 ;;199^0^TELEPHONE/POLYTRAUMA^1

 ;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---IB20P354   1809     printed  Apr 23, 2025@18:16:47                                                                                                                                                                                                    Page 2

IB20P354  ;BP/TJH-FY06 DSS CLINIC STOP CODES IB*2.0*354 PRE INIT ;29-JUN-06

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

 +2       ;;Per VHA Directive 10-93-142, this routine should not be modified.

 +3       ;

EN        ;

 +1        NEW IBEFFDT,U

 +2       ;effective date APR 1st, 2006 

           SET U="^"

           SET IBEFFDT=3060401

 +3        DO START

           DO ADD(IBEFFDT)

           DO FINISH

 +4        QUIT 

 +5       ;

START      DO MES^XPDUTL("")

 +1        DO MES^XPDUTL("FY06 DSS Clinic Stop Codes Update Starting")

 +2        QUIT 

 +3       ;

FINISH    ;

 +1       ; D MES^XPDUTL("")

 +2        DO MES^XPDUTL("FY06 DSS Clinic Stop Codes Update Complete")

 +3        QUIT 

 +4       ;

MESS(IBSTR) ;

 +1        NEW IBA

 +2        SET IBA(2)=IBSTR

 +3        SET (IBA(1),IBA(3))=""

 +4        DO MES^XPDUTL(.IBA)

 +5        QUIT 

 +6       ;

ADD(IBEFFDT) ;

 +1       ;add a new code

 +2        NEW Y,IBC,IBT,IBX,IBCODE,IBTYPE,IBDES,IBOVER

 +3        DO MESS("  Adding new codes to file 352.5")

 +4        SET IBC=0

 +5        FOR IBX=1:1

               SET IBT=$PIECE($TEXT(NCODE+IBX),";",3)

               if '$LENGTH(IBT)

                   QUIT 

               Begin DoDot:1

 +6                SET IBCODE=+$PIECE(IBT,U)

 +7                IF $DATA(^IBE(352.5,"AEFFDT",IBCODE,-IBEFFDT))

                       Begin DoDot:2

 +8                        DO MES^XPDUTL("  Duplication of non-billable type code "_IBCODE)

                       End DoDot:2

                       QUIT 

 +9                SET IBTYPE=$PIECE(IBT,U,2)

 +10               SET IBDES=$EXTRACT($PIECE(IBT,U,3),1,30)

 +11               SET IBOVER=$PIECE(IBT,U,4)

 +12               SET Y=+$$ADD3525(IBCODE,IBEFFDT,IBTYPE,IBDES,IBOVER)

                   if Y>0

                       SET IBC=IBC+1

               End DoDot:1

 +13       DO MESS("     "_IBC_$SELECT(IBC=1:" entry",1:" entries")_" added to 352.5")

 +14       QUIT 

 +15      ;

 +16      ;

ADD3525(IBCODE,IBEFFDT,IBTYPE,IBDES,IBOVER) ;

 +1       ;add a new entry

 +2        DO MES^XPDUTL("   "_IBCODE_"  "_IBDES)

 +3        NEW IBIENS,IBFDA,IBER,IBRET

 +4        SET IBRET=""

 +5        SET IBIENS="+1,"

 +6        SET IBFDA(352.5,IBIENS,.01)=IBCODE

 +7        SET IBFDA(352.5,IBIENS,.02)=IBEFFDT

 +8        SET IBFDA(352.5,IBIENS,.03)=IBTYPE

 +9        SET IBFDA(352.5,IBIENS,.04)=IBDES

 +10       if IBOVER

               SET IBFDA(352.5,IBIENS,.05)=1

 +11       DO UPDATE^DIE("","IBFDA","IBRET","IBER")

 +12       IF $DATA(IBER)

               DO MES^XPDUTL(IBER("DIERR",1,"TEXT",1))

 +13       QUIT $GET(IBRET(1))

 +14      ;

 +15      ;new non-billable type data

NCODE     ;;code^billable type^description^override flag

 +1       ;;197^2^POLYTRAUMA INDIVIDUAL^1

 +2       ;;198^2^POLYTRAUMA GROUP^1

 +3       ;;199^0^TELEPHONE/POLYTRAUMA^1

 +4       ;