IB488PRE.m

IB488PRE ;ALB/JMM - SET UP NEW BILLING ERROR IN DD FOR NO PROCEDURES IN A CLAIM ; 4/9/14 9:33am

 ;;2.0;INTEGRATED BILLING;**488**;21-MAR-94;Build 184

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

 ;

 ; Add new IB ERROR

 N DIC,X,DLAYGO,DIK,DA

 S DA=$O(^IBE(350.8,"B","IB352",""))

 S DIK="^IBE(350.8,"

 I DA'="" D ^DIK

 S DIC="^IBE(350.8,"

 S DLAYGO=350.8

 S DIC(0)="BL"

 S X="IB352"

 S DIC("DR")=".02///An outpt. inst. claim must contain at least one Procedure Code.;.03///IB352;.04///1;.05///1"

 D ^DIC

 K DIC,X,DLAYGO

 ;

 ; Add new IB ERROR

 ;N DIC,X ; WCJ

 S DA=$O(^IBE(350.8,"B","IB353",""))

 S DIK="^IBE(350.8,"

 I DA'="" D ^DIK

 S DIC="^IBE(350.8,"

 S DLAYGO=350.8

 S DIC(0)="BL"

 S X="IB353"

 S DIC("DR")=".02///A professional claim must contain at least one Procedure Code.;.03///IB353;.04///1;.05///1"

 D ^DIC

 K DIC,X,DLAYGO

 ;

 ; Add new IB ERROR

 ;N DIC,X ; WCJ

 S DA=$O(^IBE(350.8,"B","IB488",""))

 S DIK="^IBE(350.8,"

 I DA'="" D ^DIK

 S DIC="^IBE(350.8,"

 S DLAYGO=350.8

 S DIC(0)="BL"

 S X="IB488"

 S DIC("DR")=".02///A claim cannot have a Primary Payer ID of HPRNT/SPRNT.;.03///IB488;.04///1;.05///1"

 D ^DIC

 K DIC,X,DLAYGO

 ;

 ; Add new IB ERROR

 ;N DIC,X ; WCJ

 S DA=$O(^IBE(350.8,"B","IB489",""))

 S DIK="^IBE(350.8,"

 I DA'="" D ^DIK

 S DIC="^IBE(350.8,"

 S DLAYGO=350.8

 S DIC(0)="BL"

 S X="IB489"

 S DIC("DR")=".02///Printing to a Clearinghouse is no longer an available option.;.03///IB489;.04///1;.05///1"

 D ^DIC

 K DIC,X,DLAYGO

 ;

 ; Update Workers' Comp. 

 N Z,DA,DIE,X,Y,DR

 D BMES^XPDUTL("Updating RATE TYPE file with electronic billable flag")

 F Z="WORKERS' COMP." S DA=$O(^DGCR(399.3,"B",Z,"")) I DA,'$P(^DGCR(399.3,DA,0),U,10) S DIE="^DGCR(399.3,",DR=".1///1" D ^DIE

 ;

 ; delete all output formatter (O.F.) data elements included in build

 D DELOF

 Q

 ;

DELOF   ; Delete included OF entries

 NEW FILE,DIK,LN,TAG,DATA,PCE,DA,Y

 F FILE=5,6,7 S DIK="^IBA(364."_FILE_"," F LN=2:1 S TAG="ENT"_FILE_"+"_LN,DATA=$P($T(@TAG),";;",2) Q:DATA=""  D

 .F PCE=2:1 S DA=$P(DATA,U,PCE) Q:'DA  I $D(^IBA("364."_FILE,DA,0)) D ^DIK

 .Q

  ; Also delete entries which are not going to be re-added later.  These are non-functioning entries in file 364.6.

 S DIK="^IBA(364.6,"

 F LN=2:1 S TAG="DEL6"_"+"_LN,DATA=$P($T(@TAG),";;",2) Q:DATA=""  D

 .F PCE=2:1 S DA=$P(DATA,U,PCE) Q:'DA  I $D(^IBA("364.6",DA,0)) D ^DIK

 ;

 S DIK="^IBA(364.7,"

 F LN=2:1 S TAG="DEL7"_"+"_LN,DATA=$P($T(@TAG),";;",2) Q:DATA=""  D

 .F PCE=2:1 S DA=$P(DATA,U,PCE) Q:'DA  I $D(^IBA("364.7",DA,0)) D ^DIK

 Q

 ; 

DEL6    ; remove O.F. entries in file 364.6 (not re-added)

 ;

 ;;^59^

 ;;^1017^1018^1019^1020^

 ;;^1082^1311^1314^1083^1833^1084^1085^1086^1087^1088^1089^1090^1091^1852^

 ;;^1444^1464^

 ;;^1809^1810^1811^1812^1813^1814^1815^1816^1817^1828^

 ;;^1853^1854^1855^1856^1857^1858^1859^1860^

 ;;^2224^2225^2226^2227

 Q

 ;

DEL7    ; remove O.F. entries in file 364.7 (not re-added)

 ;

 ;;^17^18^79^80^29^413^

 ;;^1509^1510^1511^1512^1513^1514^1515^1516^1517^1528^

 ;;^1552^1553^1554^1555^1556^1557^1558^1559^1560^

 ;;^1908^1924^1925^1926^

 ;;

 Q

 ;

INCLUDE(FILE,Y) ;CODE TO DECIDE WHICH FILE ENTRIES CAN BE INCLUDED IN BUILD

 ;FILE = FILE LIST WE SHOULD USE 5=364.5,6=364.6,7=364.7, Y = GLOBAL IEN

 ;

 N IBOUT,Z,Z0,LINE,TAG

 I Y>9999 S IBOUT=0 G INCQ1

 F LINE=2:1  S TAG="ENT"_FILE_"+"_LINE Q:$P($T(@TAG),";;",2)=""  I $P($T(@TAG),";;",2)[(U_+Y_U) S IBOUT=1 Q

INCQ1 Q +$G(IBOUT)

 ;

ENT5 ;ENTRIES IN 364.5 WE NEED

 ;

 ;;^91^110^122^130^132^139^140^141^149^161^182^

 ;;^213^219^237^355^356^376^377^

 ;;

 ;

ENT6 ;ENTRIES IN 364.6 WE NEED

 ;

 ;;^14^15^29^40^43^52^53^59^66^67^

 ;;^104^105^109^110^117^119^120^121^122^127^130^136^

 ;;^579^784^814^815^960^961^964^971^987^988^

 ;;^1097^1098^1099^

 ;;^1100^1101^1102^1103^1104^1194^1195^1196^

 ;;^1214^1215^1216^1217^1232^1233^1242^1243^1252^1253^1260^1261^1262^1263^1285^1286^1296^1297^1298^1299^

 ;;^1321^

 ;;^1474^1477^1478^1487^

 ;;^1805^1806^1807^1808^1839^1840^

 ;;^1927^1928^1929^

 ;;^2029^2030^2031^2032^2033^2034^

 ;;^2208^2227^2230^2234^2238^2239^2240^2241^2242^2243^2244^2245^2246^2247^2248^2249^2250^

 ;;

 ;

ENT7 ;ENTRIES IN 364.7 WE NEED

 ;`

 ;;^22^23^29^42^61^63^

 ;;^122^124^128^129^142^167^170^180^193^

 ;;^378^379^380^381^382^383^384^385^391^392^393^

 ;;^410^411^412^413^428^429^438^439^451^452^462^463^464^465^

 ;;^650^651^652^653^657^662^

 ;;^796^844^845^

 ;;^934^948^955^956^989^990^

 ;;^1015^1039^

 ;;^1120^1121^1122^1127^1138^1139^1140^1144^1145^1150^1158^1159^

 ;;^1162^1163^1164^1165^1168^1169^1174^1175^1177^1178^1199^1297^

 ;;^1505^1506^1507^1508^1539^1540^

 ;;^1627^1628^1629^1675^1676^1677^1678^1679^1680^1681^

 ;;^1728^1729^1730^^1731^1732^1733^

 ;;^1908^1927^1930^1931^1932^1933^1934^1935^1936^1937^1938^1939^1940^1941^1942^1943^1944^

 ;;^2227^

 ;;

 ;

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---IB488PRE   4890     printed  Mar 13, 2025@21:10:35                                                                                                                                                                                                    Page 2

IB488PRE  ;ALB/JMM - SET UP NEW BILLING ERROR IN DD FOR NO PROCEDURES IN A CLAIM ; 4/9/14 9:33am

 +1       ;;2.0;INTEGRATED BILLING;**488**;21-MAR-94;Build 184

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

 +3       ;

 +4       ; Add new IB ERROR

 +5        NEW DIC,X,DLAYGO,DIK,DA

 +6        SET DA=$ORDER(^IBE(350.8,"B","IB352",""))

 +7        SET DIK="^IBE(350.8,"

 +8        IF DA'=""

               DO ^DIK

 +9        SET DIC="^IBE(350.8,"

 +10       SET DLAYGO=350.8

 +11       SET DIC(0)="BL"

 +12       SET X="IB352"

 +13       SET DIC("DR")=".02///An outpt. inst. claim must contain at least one Procedure Code.;.03///IB352;.04///1;.05///1"

 +14       DO ^DIC

 +15       KILL DIC,X,DLAYGO

 +16      ;

 +17      ; Add new IB ERROR

 +18      ;N DIC,X ; WCJ

 +19       SET DA=$ORDER(^IBE(350.8,"B","IB353",""))

 +20       SET DIK="^IBE(350.8,"

 +21       IF DA'=""

               DO ^DIK

 +22       SET DIC="^IBE(350.8,"

 +23       SET DLAYGO=350.8

 +24       SET DIC(0)="BL"

 +25       SET X="IB353"

 +26       SET DIC("DR")=".02///A professional claim must contain at least one Procedure Code.;.03///IB353;.04///1;.05///1"

 +27       DO ^DIC

 +28       KILL DIC,X,DLAYGO

 +29      ;

 +30      ; Add new IB ERROR

 +31      ;N DIC,X ; WCJ

 +32       SET DA=$ORDER(^IBE(350.8,"B","IB488",""))

 +33       SET DIK="^IBE(350.8,"

 +34       IF DA'=""

               DO ^DIK

 +35       SET DIC="^IBE(350.8,"

 +36       SET DLAYGO=350.8

 +37       SET DIC(0)="BL"

 +38       SET X="IB488"

 +39       SET DIC("DR")=".02///A claim cannot have a Primary Payer ID of HPRNT/SPRNT.;.03///IB488;.04///1;.05///1"

 +40       DO ^DIC

 +41       KILL DIC,X,DLAYGO

 +42      ;

 +43      ; Add new IB ERROR

 +44      ;N DIC,X ; WCJ

 +45       SET DA=$ORDER(^IBE(350.8,"B","IB489",""))

 +46       SET DIK="^IBE(350.8,"

 +47       IF DA'=""

               DO ^DIK

 +48       SET DIC="^IBE(350.8,"

 +49       SET DLAYGO=350.8

 +50       SET DIC(0)="BL"

 +51       SET X="IB489"

 +52       SET DIC("DR")=".02///Printing to a Clearinghouse is no longer an available option.;.03///IB489;.04///1;.05///1"

 +53       DO ^DIC

 +54       KILL DIC,X,DLAYGO

 +55      ;

 +56      ; Update Workers' Comp. 

 +57       NEW Z,DA,DIE,X,Y,DR

 +58       DO BMES^XPDUTL("Updating RATE TYPE file with electronic billable flag")

 +59       FOR Z="WORKERS' COMP."

               SET DA=$ORDER(^DGCR(399.3,"B",Z,""))

               IF DA

                   IF '$PIECE(^DGCR(399.3,DA,0),U,10)

                       SET DIE="^DGCR(399.3,"

                       SET DR=".1///1"

                       DO ^DIE

 +60      ;

 +61      ; delete all output formatter (O.F.) data elements included in build

 +62       DO DELOF

 +63       QUIT 

 +64      ;

DELOF     ; Delete included OF entries

 +1        NEW FILE,DIK,LN,TAG,DATA,PCE,DA,Y

 +2        FOR FILE=5,6,7

               SET DIK="^IBA(364."_FILE_","

               FOR LN=2:1

                   SET TAG="ENT"_FILE_"+"_LN

                   SET DATA=$PIECE($TEXT(@TAG),";;",2)

                   if DATA=""

                       QUIT 

                   Begin DoDot:1

 +3                    FOR PCE=2:1

                           SET DA=$PIECE(DATA,U,PCE)

                           if 'DA

                               QUIT 

                           IF $DATA(^IBA("364."_FILE,DA,0))

                               DO ^DIK

 +4                    QUIT 

                   End DoDot:1

 +5       ; Also delete entries which are not going to be re-added later.  These are non-functioning entries in file 364.6.

 +6        SET DIK="^IBA(364.6,"

 +7        FOR LN=2:1

               SET TAG="DEL6"_"+"_LN

               SET DATA=$PIECE($TEXT(@TAG),";;",2)

               if DATA=""

                   QUIT 

               Begin DoDot:1

 +8                FOR PCE=2:1

                       SET DA=$PIECE(DATA,U,PCE)

                       if 'DA

                           QUIT 

                       IF $DATA(^IBA("364.6",DA,0))

                           DO ^DIK

               End DoDot:1

 +9       ;

 +10       SET DIK="^IBA(364.7,"

 +11       FOR LN=2:1

               SET TAG="DEL7"_"+"_LN

               SET DATA=$PIECE($TEXT(@TAG),";;",2)

               if DATA=""

                   QUIT 

               Begin DoDot:1

 +12               FOR PCE=2:1

                       SET DA=$PIECE(DATA,U,PCE)

                       if 'DA

                           QUIT 

                       IF $DATA(^IBA("364.7",DA,0))

                           DO ^DIK

               End DoDot:1

 +13       QUIT 

 +14      ; 

DEL6      ; remove O.F. entries in file 364.6 (not re-added)

 +1       ;

 +2       ;;^59^

 +3       ;;^1017^1018^1019^1020^

 +4       ;;^1082^1311^1314^1083^1833^1084^1085^1086^1087^1088^1089^1090^1091^1852^

 +5       ;;^1444^1464^

 +6       ;;^1809^1810^1811^1812^1813^1814^1815^1816^1817^1828^

 +7       ;;^1853^1854^1855^1856^1857^1858^1859^1860^

 +8       ;;^2224^2225^2226^2227

 +9        QUIT 

 +10      ;

DEL7      ; remove O.F. entries in file 364.7 (not re-added)

 +1       ;

 +2       ;;^17^18^79^80^29^413^

 +3       ;;^1509^1510^1511^1512^1513^1514^1515^1516^1517^1528^

 +4       ;;^1552^1553^1554^1555^1556^1557^1558^1559^1560^

 +5       ;;^1908^1924^1925^1926^

 +6       ;;

 +7        QUIT 

 +8       ;

INCLUDE(FILE,Y) ;CODE TO DECIDE WHICH FILE ENTRIES CAN BE INCLUDED IN BUILD

 +1       ;FILE = FILE LIST WE SHOULD USE 5=364.5,6=364.6,7=364.7, Y = GLOBAL IEN

 +2       ;

 +3        NEW IBOUT,Z,Z0,LINE,TAG

 +4        IF Y>9999

               SET IBOUT=0

               GOTO INCQ1

 +5        FOR LINE=2:1

               SET TAG="ENT"_FILE_"+"_LINE

               if $PIECE($TEXT(@TAG),";;",2)=""

                   QUIT 

               IF $PIECE($TEXT(@TAG),";;",2)[(U_+Y_U)

                   SET IBOUT=1

                   QUIT 

INCQ1      QUIT +$GET(IBOUT)

 +1       ;

ENT5      ;ENTRIES IN 364.5 WE NEED

 +1       ;

 +2       ;;^91^110^122^130^132^139^140^141^149^161^182^

 +3       ;;^213^219^237^355^356^376^377^

 +4       ;;

 +5       ;

ENT6      ;ENTRIES IN 364.6 WE NEED

 +1       ;

 +2       ;;^14^15^29^40^43^52^53^59^66^67^

 +3       ;;^104^105^109^110^117^119^120^121^122^127^130^136^

 +4       ;;^579^784^814^815^960^961^964^971^987^988^

 +5       ;;^1097^1098^1099^

 +6       ;;^1100^1101^1102^1103^1104^1194^1195^1196^

 +7       ;;^1214^1215^1216^1217^1232^1233^1242^1243^1252^1253^1260^1261^1262^1263^1285^1286^1296^1297^1298^1299^

 +8       ;;^1321^

 +9       ;;^1474^1477^1478^1487^

 +10      ;;^1805^1806^1807^1808^1839^1840^

 +11      ;;^1927^1928^1929^

 +12      ;;^2029^2030^2031^2032^2033^2034^

 +13      ;;^2208^2227^2230^2234^2238^2239^2240^2241^2242^2243^2244^2245^2246^2247^2248^2249^2250^

 +14      ;;

 +15      ;

ENT7      ;ENTRIES IN 364.7 WE NEED

 +1       ;`

 +2       ;;^22^23^29^42^61^63^

 +3       ;;^122^124^128^129^142^167^170^180^193^

 +4       ;;^378^379^380^381^382^383^384^385^391^392^393^

 +5       ;;^410^411^412^413^428^429^438^439^451^452^462^463^464^465^

 +6       ;;^650^651^652^653^657^662^

 +7       ;;^796^844^845^

 +8       ;;^934^948^955^956^989^990^

 +9       ;;^1015^1039^

 +10      ;;^1120^1121^1122^1127^1138^1139^1140^1144^1145^1150^1158^1159^

 +11      ;;^1162^1163^1164^1165^1168^1169^1174^1175^1177^1178^1199^1297^

 +12      ;;^1505^1506^1507^1508^1539^1540^

 +13      ;;^1627^1628^1629^1675^1676^1677^1678^1679^1680^1681^

 +14      ;;^1728^1729^1730^^1731^1732^1733^

 +15      ;;^1908^1927^1930^1931^1932^1933^1934^1935^1936^1937^1938^1939^1940^1941^1942^1943^1944^

 +16      ;;^2227^

 +17      ;;

 +18      ;

 +19       QUIT