Routine: IB20P351

IB20P351 ;ALB/CXW-FY07 DSS CLINIC STOP CODES IB*2.0*351 POST INIT ;25-SEP-06

 ;;2.0;INTEGRATED BILLING;**351**;21-MAR-94;Build 4

 ;;Per VHA Directive 2004-038, this routine should not be modified.

POST ;

 N IBEFFDT,U

 S U="^",IBEFFDT=3061001 ;effective date OCT 1st, 2006

 D START,ADD(IBEFFDT),UPDATE(IBEFFDT),FINISH

START D BMES^XPDUTL("FY07 DSS Clinic Stop Codes, Post-Install Starting")

FINISH D BMES^XPDUTL("FY07 DSS Clinic Stop Codes, Post-Install Complete")

ADD(IBEFFDT) ;

 ;add a new code

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

 D BMES^XPDUTL(" 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)

 . S IBY=$S(IBCODE=372:3041001,IBCODE=373:3041001,1:IBEFFDT)

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

 . . D BMES^XPDUTL(" Duplication of stop 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,IBY,IBTYPE,IBDES,IBOVER) S:Y>0 IBC=IBC+1

 D BMES^XPDUTL("     "_IBC_$S(IBC<2:" entry",1:" entries")_" added to 352.5")

UPDATE(IBEFFDT) ;

 ;update an old code

 N Y,IB1,IBC,IBT,IBX,IBCODE,IBMSG,IBTYPE,IBDES,IBOVER,IBLSTDT

 S (IBC,IBMSG(1),IBMSG(2),IBMSG(3))=0

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

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

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

 . . D BMES^XPDUTL(" Duplication of stop code "_IBCODE)

 . S IBLSTDT=$O(^IBE(352.5,"AEFFDT",IBCODE,-9999999))

 . I +IBLSTDT=0 D  Q

 . . D BMES^XPDUTL(" Code "_IBCODE_" not found in file 352.5")

 . S IB1=$O(^IBE(352.5,"AEFFDT",IBCODE,IBLSTDT,0))

 . S IB1=$G(^IBE(352.5,IB1,0))

 . S IBTYPE=$S($P(IBT,U,2):$P(IBT,U,2),1:$P(IB1,U,3))

 . S IBDES=$S($P(IBT,U,3)'="":$E($P(IBT,U,3),1,30),1:$P(IB1,U,4))

 . S IBOVER=$S($P(IBT,U,4)'="":$P(IBT,U,4),1:$P(IB1,U,5))

 . I $P(IBT,U,2) D

 . . I 'IBMSG(1) D BMES^XPDUTL(" Updating billable type in file 352.5") S IBMSG(1)=1

 . I $P(IBT,U,3)'="" D

 . . I 'IBMSG(2),$P(IBT,U,3)'="" D BMES^XPDUTL(" Updating description in file 352.5") S IBMSG(2)=1

 . I '$P(IBT,U,2),$P(IBT,U,3)="" D

 . . I 'IBMSG(3) D BMES^XPDUTL(" Updating effective date in file 352.5") S IBMSG(3)=1

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

 D BMES^XPDUTL("     "_IBC_$S(IBC<2:" update",1:" updates")_" added to file 352.5")

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

 ;add a new entry

 D BMES^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 BMES^XPDUTL(IBER("DIERR",1,"TEXT",1))

 Q $G(IBRET(1))

 ;new codes

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

 ;;372^1^MOVE PROGRAM INDIVIDUAL

 ;;373^1^MOVE PROGRAM GROUP

 ;;159^1^COMPLEMENTARY ALTERNATIVE THERAPIES

 ;;182^0^TELEPHONE CASE MANAGEMENT^1

 ;;310301^0^TRANSRECTAL ULTRASOUND F-U IND^1

 ;;394301^0^TRANSRECTAL ULTRASOUND F-U GRP^1

 ;;571^0^RETURN VET OUTREACH ED/CARE-IND^1

 ;;572^0^RETURN VET OUTREACH ED/CARE-GRP^1

 ;;582^1^PSYC/SOC REHAB/RECOV CENTR-IND

 ;;583^1^PSYC/SOC REHAB/RECOV CENTR-GRP

 ;;584^0^TELEPHONE PSYC/SOC REHAB/RECOVERY^1

 ;;643^0^SEND-OUT PROCEDURES - RADIOLOGY^1

 ;;697^0^CHART CONSULT

 ;codes update

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

 ;;142^1^^0

 ;;640

 ;;641

 ;;642

 ;;656

 ;;670

 ;;704^^FEMALE GENDER SPECIFIC CANCER SCREENING

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P351   3618     printed  Mar 13, 2025@21:07:05                                                                                                                                                                                                    Page 2

IB20P351  ;ALB/CXW-FY07 DSS CLINIC STOP CODES IB*2.0*351 POST INIT ;25-SEP-06

 +1       ;;2.0;INTEGRATED BILLING;**351**;21-MAR-94;Build 4

 +2       ;;Per VHA Directive 2004-038, this routine should not be modified.

 +3       ;

POST      ;

 +1        NEW IBEFFDT,U

 +2       ;effective date OCT 1st, 2006

           SET U="^"

           SET IBEFFDT=3061001

 +3        DO START

           DO ADD(IBEFFDT)

           DO UPDATE(IBEFFDT)

           DO FINISH

 +4        QUIT

 +5       ;

START      DO BMES^XPDUTL("FY07 DSS Clinic Stop Codes, Post-Install Starting")

 +1        QUIT

 +2       ;

FINISH     DO BMES^XPDUTL("FY07 DSS Clinic Stop Codes, Post-Install Complete")

 +1        QUIT

 +2       ;

 +3       ;

ADD(IBEFFDT) ;

 +1       ;add a new code

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

 +3        DO BMES^XPDUTL(" 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                SET IBY=$SELECT(IBCODE=372:3041001,IBCODE=373:3041001,1:IBEFFDT)

 +8                IF $DATA(^IBE(352.5,"AEFFDT",IBCODE,-IBY))

                       Begin DoDot:2

 +9                        DO BMES^XPDUTL(" Duplication of stop code "_IBCODE)

                       End DoDot:2

                       QUIT

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

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

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

 +13               SET Y=+$$ADD3525(IBCODE,IBY,IBTYPE,IBDES,IBOVER)

                   if Y>0

                       SET IBC=IBC+1

               End DoDot:1

 +14       DO BMES^XPDUTL("     "_IBC_$SELECT(IBC<2:" entry",1:" entries")_" added to 352.5")

 +15       QUIT

 +16      ;

UPDATE(IBEFFDT) ;

 +1       ;update an old code

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

 +3        SET (IBC,IBMSG(1),IBMSG(2),IBMSG(3))=0

 +4        FOR IBX=1:1

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

               if '$LENGTH(IBT)

                   QUIT

               Begin DoDot:1

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

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

                       Begin DoDot:2

 +7                        DO BMES^XPDUTL(" Duplication of stop code "_IBCODE)

                       End DoDot:2

                       QUIT

 +8                SET IBLSTDT=$ORDER(^IBE(352.5,"AEFFDT",IBCODE,-9999999))

 +9                IF +IBLSTDT=0

                       Begin DoDot:2

 +10                       DO BMES^XPDUTL(" Code "_IBCODE_" not found in file 352.5")

                       End DoDot:2

                       QUIT

 +11               SET IB1=$ORDER(^IBE(352.5,"AEFFDT",IBCODE,IBLSTDT,0))

 +12               SET IB1=$GET(^IBE(352.5,IB1,0))

 +13               SET IBTYPE=$SELECT($PIECE(IBT,U,2):$PIECE(IBT,U,2),1:$PIECE(IB1,U,3))

 +14               SET IBDES=$SELECT($PIECE(IBT,U,3)'="":$EXTRACT($PIECE(IBT,U,3),1,30),1:$PIECE(IB1,U,4))

 +15               SET IBOVER=$SELECT($PIECE(IBT,U,4)'="":$PIECE(IBT,U,4),1:$PIECE(IB1,U,5))

 +16               IF $PIECE(IBT,U,2)

                       Begin DoDot:2

 +17                       IF 'IBMSG(1)

                               DO BMES^XPDUTL(" Updating billable type in file 352.5")

                               SET IBMSG(1)=1

                       End DoDot:2

 +18               IF $PIECE(IBT,U,3)'=""

                       Begin DoDot:2

 +19                       IF 'IBMSG(2)

                               IF $PIECE(IBT,U,3)'=""

                                   DO BMES^XPDUTL(" Updating description in file 352.5")

                                   SET IBMSG(2)=1

                       End DoDot:2

 +20               IF '$PIECE(IBT,U,2)

                       IF $PIECE(IBT,U,3)=""

                           Begin DoDot:2

 +21                           IF 'IBMSG(3)

                                   DO BMES^XPDUTL(" Updating effective date in file 352.5")

                                   SET IBMSG(3)=1

                           End DoDot:2

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

                   if Y>0

                       SET IBC=IBC+1

               End DoDot:1

 +23       DO BMES^XPDUTL("     "_IBC_$SELECT(IBC<2:" update",1:" updates")_" added to file 352.5")

 +24       QUIT

 +25      ;

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

 +1       ;add a new entry

 +2        DO BMES^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 BMES^XPDUTL(IBER("DIERR",1,"TEXT",1))

 +13       QUIT $GET(IBRET(1))

 +14      ;

 +15      ;new codes

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

 +1       ;;372^1^MOVE PROGRAM INDIVIDUAL

 +2       ;;373^1^MOVE PROGRAM GROUP

 +3       ;;159^1^COMPLEMENTARY ALTERNATIVE THERAPIES

 +4       ;;182^0^TELEPHONE CASE MANAGEMENT^1

 +5       ;;310301^0^TRANSRECTAL ULTRASOUND F-U IND^1

 +6       ;;394301^0^TRANSRECTAL ULTRASOUND F-U GRP^1

 +7       ;;571^0^RETURN VET OUTREACH ED/CARE-IND^1

 +8       ;;572^0^RETURN VET OUTREACH ED/CARE-GRP^1

 +9       ;;582^1^PSYC/SOC REHAB/RECOV CENTR-IND

 +10      ;;583^1^PSYC/SOC REHAB/RECOV CENTR-GRP

 +11      ;;584^0^TELEPHONE PSYC/SOC REHAB/RECOVERY^1

 +12      ;;643^0^SEND-OUT PROCEDURES - RADIOLOGY^1

 +13      ;;697^0^CHART CONSULT

 +14      ;

 +15      ;codes update

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

 +1       ;;142^1^^0

 +2       ;;640

 +3       ;;641

 +4       ;;642

 +5       ;;656

 +6       ;;670

 +7       ;;704^^FEMALE GENDER SPECIFIC CANCER SCREENING

 +8       ;

IB20P351.m