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 ---[H[J[2J[HIB488PRE 4890 printed Apr 09, 2024@21:03: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
