IBY358PO ;ALB/WCJ - Post Install for IB patch 358 ;28-JUL-2005
;;2.0;INTEGRATED BILLING;**358**;21-MAR-94
;
EN ;
N XPDIDTOT S XPDIDTOT=1
D CLEAN ; 1. Clean up IDs with qualifiers TJ & 24
;
EX ;
Q
CLEAN ; Clean up IDs with qualifiers TJ & 24
D BMES^XPDUTL(" STEP 1 of "_XPDIDTOT)
D MES^XPDUTL("-------------")
D MES^XPDUTL("Cleaning up IDs with Qualifiers 24, EI, TJ ....")
;
; this will loop through all qualifiers with internal values of
; 16 (X12 CODE 24) and 21 (X12 CODE TJ). The X12 codes should be
; internal 32 (X12 CODE EI) for individuals and internal 21 (X12 CODE
; TJ) for labs/facilities. IDs will be modified or deleted as
; necessary.
;
N QUAL,PROV,IORF,PROVIEN,IDS,I,J,K,FLAG
;
F QUAL=21,16 D
. S PROV=""
. F S PROV=$O(^IBA(355.9,"AC",QUAL,"*ALL*",PROV)) Q:PROV="" D
.. Q:PROV'["IBA(355.93" ; Only NonVA providers
.. S PROVIEN=+PROV
.. S IORF=$P($G(^IBA(355.93,PROVIEN,0)),U,2) ; (2)Individual OR (1)Facility
.. ;
.. K IDS
.. D GETALL(PROV,.IDS)
.. Q:'$D(IDS) ; Nothing to convert (should not stop here)
.. ;
.. ; Individual already having EI, Delete 24s & TJs
.. I IORF=2,$G(IDS(32)) D Q
... F K=16,21 F I=0,1,2 F J=0:1:3 I $D(IDS(K,I,J)) D DELETE(IDS(K,I,J))
.. ;
.. ; Lab/Fac with TJs already, delete 24s
.. I IORF=1,$G(IDS(21)) D Q
... F I=0,1,2 F J=0:1:3 I $D(IDS(16,I,J)) D DELETE(IDS(16,I,J))
.. ;
.. ; Lab/Fac with 24s but no TJs, edit or delete 24s as appropriate
.. I IORF=1,'$G(IDS(21)),$G(IDS(16)) D Q
... S FLAG=0
... F I=0,1,2 F J=0:1:3 I $D(IDS(16,I,J)) D MODIFY(IDS(16,I,J),21):'FLAG,DELETE(IDS(16,I,J)):FLAG S FLAG=1
.. ;
.. ; Individual with TJs or 24s but no EIs, edit or delete as appropriate
.. I IORF=2,'$G(IDS(32)) D Q
... ;
... S FLAG=0
... F I=0,1,2 F J=0:1:3 F K=21,16 I $D(IDS(K,I,J)) D MODIFY(IDS(K,I,J),32):'FLAG,DELETE(IDS(K,I,J)):FLAG S FLAG=1
CLEANX ;
D MES^XPDUTL(" Done.")
D UPDATE^XPDID(1)
Q
;
; pass in PROV IEN;IBA(355.93,
; return IDS array IDS(IEN35597,FORMTYPE,CARETYPE)=IEN3559
; IDS(IEN35597)=COUNTER
GETALL(PROV,IDS) ;
N I,J,K
F I=0,1,2 D
. F J=0:1:3 D
.. F K=16,21,32 D
... I $D(^IBA(355.9,"AUNIQ",PROV,"*ALL*","*N/A*",I,J,K)) D
.... S IDS(K,I,J)=$O(^IBA(355.9,"AUNIQ",PROV,"*ALL*","*N/A*",I,J,K,0))
.... S IDS(K)=$G(IDS(K))+1
Q
;
DELETE(IEN) ;
N DIK,DA
S DIK="^IBA(355.9,",DA=+IEN D ^DIK
Q
;
MODIFY(IEN,QUAL) ;
N DIE,DA,DR
S DIE="^IBA(355.9,",DA=+IEN,DR=".04////0;.05////0;.06////"_QUAL D ^DIE
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBY358PO 2549 printed Apr 09, 2024@21:28:47 Page 2
IBY358PO ;ALB/WCJ - Post Install for IB patch 358 ;28-JUL-2005
+1 ;;2.0;INTEGRATED BILLING;**358**;21-MAR-94
+2 ;
EN ;
+1 NEW XPDIDTOT
SET XPDIDTOT=1
+2 ; 1. Clean up IDs with qualifiers TJ & 24
DO CLEAN
+3 ;
EX ;
+1 QUIT
CLEAN ; Clean up IDs with qualifiers TJ & 24
+1 DO BMES^XPDUTL(" STEP 1 of "_XPDIDTOT)
+2 DO MES^XPDUTL("-------------")
+3 DO MES^XPDUTL("Cleaning up IDs with Qualifiers 24, EI, TJ ....")
+4 ;
+5 ; this will loop through all qualifiers with internal values of
+6 ; 16 (X12 CODE 24) and 21 (X12 CODE TJ). The X12 codes should be
+7 ; internal 32 (X12 CODE EI) for individuals and internal 21 (X12 CODE
+8 ; TJ) for labs/facilities. IDs will be modified or deleted as
+9 ; necessary.
+10 ;
+11 NEW QUAL,PROV,IORF,PROVIEN,IDS,I,J,K,FLAG
+12 ;
+13 FOR QUAL=21,16
Begin DoDot:1
+14 SET PROV=""
+15 FOR
SET PROV=$ORDER(^IBA(355.9,"AC",QUAL,"*ALL*",PROV))
if PROV=""
QUIT
Begin DoDot:2
+16 ; Only NonVA providers
if PROV'["IBA(355.93"
QUIT
+17 SET PROVIEN=+PROV
+18 ; (2)Individual OR (1)Facility
SET IORF=$PIECE($GET(^IBA(355.93,PROVIEN,0)),U,2)
+19 ;
+20 KILL IDS
+21 DO GETALL(PROV,.IDS)
+22 ; Nothing to convert (should not stop here)
if '$DATA(IDS)
QUIT
+23 ;
+24 ; Individual already having EI, Delete 24s & TJs
+25 IF IORF=2
IF $GET(IDS(32))
Begin DoDot:3
+26 FOR K=16,21
FOR I=0,1,2
FOR J=0:1:3
IF $DATA(IDS(K,I,J))
DO DELETE(IDS(K,I,J))
End DoDot:3
QUIT
+27 ;
+28 ; Lab/Fac with TJs already, delete 24s
+29 IF IORF=1
IF $GET(IDS(21))
Begin DoDot:3
+30 FOR I=0,1,2
FOR J=0:1:3
IF $DATA(IDS(16,I,J))
DO DELETE(IDS(16,I,J))
End DoDot:3
QUIT
+31 ;
+32 ; Lab/Fac with 24s but no TJs, edit or delete 24s as appropriate
+33 IF IORF=1
IF '$GET(IDS(21))
IF $GET(IDS(16))
Begin DoDot:3
+34 SET FLAG=0
+35 FOR I=0,1,2
FOR J=0:1:3
IF $DATA(IDS(16,I,J))
if 'FLAG
DO MODIFY(IDS(16,I,J),21)
if FLAG
DO DELETE(IDS(16,I,J))
SET FLAG=1
End DoDot:3
QUIT
+36 ;
+37 ; Individual with TJs or 24s but no EIs, edit or delete as appropriate
+38 IF IORF=2
IF '$GET(IDS(32))
Begin DoDot:3
+39 ;
+40 SET FLAG=0
+41 FOR I=0,1,2
FOR J=0:1:3
FOR K=21,16
IF $DATA(IDS(K,I,J))
if 'FLAG
DO MODIFY(IDS(K,I,J),32)
if FLAG
DO DELETE(IDS(K,I,J))
SET FLAG=1
End DoDot:3
QUIT
End DoDot:2
End DoDot:1
CLEANX ;
+1 DO MES^XPDUTL(" Done.")
+2 DO UPDATE^XPDID(1)
+3 QUIT
+4 ;
+5 ; pass in PROV IEN;IBA(355.93,
+6 ; return IDS array IDS(IEN35597,FORMTYPE,CARETYPE)=IEN3559
+7 ; IDS(IEN35597)=COUNTER
GETALL(PROV,IDS) ;
+1 NEW I,J,K
+2 FOR I=0,1,2
Begin DoDot:1
+3 FOR J=0:1:3
Begin DoDot:2
+4 FOR K=16,21,32
Begin DoDot:3
+5 IF $DATA(^IBA(355.9,"AUNIQ",PROV,"*ALL*","*N/A*",I,J,K))
Begin DoDot:4
+6 SET IDS(K,I,J)=$ORDER(^IBA(355.9,"AUNIQ",PROV,"*ALL*","*N/A*",I,J,K,0))
+7 SET IDS(K)=$GET(IDS(K))+1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+8 QUIT
+9 ;
DELETE(IEN) ;
+1 NEW DIK,DA
+2 SET DIK="^IBA(355.9,"
SET DA=+IEN
DO ^DIK
+3 QUIT
+4 ;
MODIFY(IEN,QUAL) ;
+1 NEW DIE,DA,DR
+2 SET DIE="^IBA(355.9,"
SET DA=+IEN
SET DR=".04////0;.05////0;.06////"_QUAL
DO ^DIE
+3 QUIT
+4 ;
