- 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 23, 2025@18:48:27 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 ;
