Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBCEP5B

IBCEP5B.m

Go to the documentation of this file. 
  1. IBCEP5B ;ALB/TMP - EDI UTILITIES for prov ID ;29-SEP-00
  1.  ;;2.0;INTEGRATED BILLING;**137,239,232,320,348,349,592**;21-MAR-94;Build 58
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  ;
  1. NEWID(IBFILE,IBINS,IBPRV,IBPTYP,IBIEN,IBF) ; Generic add prov id
  1.  ; at both prov (file 355.9) and ins co levels (355.91)
  1.  ; IBFILE = 355.9 or 355.91 - the file being edited
  1.  ; IBINS = ien of ins co (36) or *ALL* for all ins co
  1.  ; IBPRV = vp ien of billing prov
  1.  ; IBPTYP = ien of prov type (file 355.97)
  1.  ; IBIEN = ien of entry being added (req'd)
  1.  ; IBF = 1 if deleting from ins-related options, "" from prov-related
  1.  N DIC,DIR,X,Y,Z,DA,DR,DIE,DO,DD,DLAYGO,DTOUT,DUOUT,IBQ,IBCUND,IB3559,IB35591,Q,IBDR,IBID,AFT
  1.  S IB35591(.03)="",IBPTYP=$G(IBPTYP)
  1.  F Z=.04,.05,.03 D  G:Z="" NEWQ
  1.  . I $S(Z'=.03:1,1:$S('$G(IBINS):0,1:$G(IBCUND))) D  Q:Z=""
  1.  .. N DA
  1.  .. I Z'=.03 S DIR(0)=IBFILE_","_Z
  1.  .. I Z=.03 D
  1.  ... S DIR(0)="PAO^355.95:AEMQ"
  1.  ... S DIR("S")="I $O(^IBA(355.96,""AUNIQ"","_IBINS_",Y,"_$G(IB3559(.04))_","_$G(IB3559(.05))_","_IBPTYP_",0))!($O(^IBA(355.96,""AUNIQ"","_IBINS_",Y,"_$G(IB3559(.04))_",0,"_IBPTYP_",0)))"
  1.  ... S DIR("S")=DIR("S")_"!($O(^IBA(355.96,""AUNIQ"","_IBINS_",Y,0,"_$G(IB3559(.05))_","_IBPTYP_",0)))!($O(^IBA(355.96,""AUNIQ"","_IBINS_",Y,0,0,"_IBPTYP_",0)))"
  1.  ... S DIR("?",1)="Care unit describes areas of service and is assigned by the payer, if",DIR("?")="  applicable.  Use Care Unit Maintenance to add or modify care units."
  1.  .. ;
  1.  .. I Z=.04,IBPRV["355.93",$$GET1^DIQ(355.93,+IBPRV,.02,"I")=1 D
  1.  ... I $$GET1^DIQ(355.97,IBPTYP,.03,"I")="EI" S $P(DIR(0),U,3)="K:Y'=1 X",DIR("?")="Provider ID Qualifier selected only allows institutional (UB type) forms" Q
  1.  ... I $$GET1^DIQ(355.97,IBPTYP,.03,"I")="TJ" S $P(DIR(0),U,3)="K:Y'=2 X",DIR("?")="Provider ID Qualifier selected only allows professional (CMS-1500) forms" Q
  1.  ... ;IA# 2056;IB*2.0*592
  1.  ... N AFT
  1.  ... S AFT=$$GET1^DIQ(355.97,IBPTYP,.07,"I")  ; get allowable form type for this Provider ID Type
  1.  ... I AFT="B" S $P(DIR(0),U,3)="K:"".0.1.2.4.""'[("".""_Y_""."") X",DIR("?")="Provider ID Qualifier selected allows institutional, professional or both" Q
  1.  ... I AFT="P" S $P(DIR(0),U,3)="K:Y'=2 X",DIR("?")="Provider ID Qualifier selected only allows professional (CMS-1500) forms" Q
  1.  ... I AFT="I" S $P(DIR(0),U,3)="K:Y'=1 X",DIR("?")="Provider ID Qualifier selected only allows institutional (UB type) forms" Q
  1.  .. ;
  1.  .. S DA=0
  1.  .. I Z=.04,$P($G(^IBE(355.97,+IBPTYP,0)),U,3)="1A" D SETDIR(.DIR)
  1.  .. D ^DIR K DIR
  1.  .. I $D(DTOUT)!$D(DUOUT) S Z="" K IB3559,IB35591 Q
  1.  .. S IB3559(Z)=$S(Z'=.03:$P(Y,U),1:$S($P(Y,U)>0:$P(Y,U),1:"*N/A*"))
  1.  . I Z=.05 D
  1.  .. S IBCUND=$$CAREUN^IBCEP3(IBINS,IBPTYP,IB3559(.04),IB3559(.05),IB3559(.05)=3)
  1.  .. S:'IBCUND!($G(IB3559(.03))=0) IB3559(.03)="*N/A*"
  1.  .. I '$G(IBINS) S IBINS="*ALL*"
  1.  . I Z=.03 D CAREUN^IBCEP5C
  1.  ;
  1.  I $D(IB3559) D
  1.  . N Q,Z2,Z3,Z4,Z5,Z6,IBLAST,IBOK,DIR,Y,X
  1.  . S IBLAST=0
  1.  . D DISP^IBCEP4("Q",IBINS,IBPTYP,IB3559(.04),IB3559(.05),1)
  1.  . W !!,"THE FOLLOWING WAS CHOSEN:"
  1.  . S Q=0 F  S Q=$O(Q(Q)) Q:'Q  W !,?3,Q(Q)
  1.  . I IBCUND W !,?3,"CARE UNIT: "_$$EXPAND^IBTRE(355.96,.01,IB3559(.03))
  1.  . S Z2=IBINS,Z3=IB35591(.03),Z4=IB3559(.04),Z5=IB3559(.05),Z6=IBPTYP
  1.  . S IBOK=1
  1.  . ; If both forms, chk for specific
  1.  . I 'Z4 S IBOK=$$COMBOK^IBCEP5C(IBFILE,IBPRV_U_4_U_Z2_U_Z3_U_Z4_U_Z5_U_Z6,1,$G(IBFILE)=355.91)
  1.  . ; If specific form, chk for all
  1.  . I IBOK,Z4 S IBOK=$$COMBOK^IBCEP5C(IBFILE,IBPRV_U_4_U_Z2_U_Z3_U_Z4_U_Z5_U_Z6,0,$G(IBFILE)=355.91)
  1.  . ; If both care types, chk for specific
  1.  . I IBOK,'Z5 S IBOK=$$COMBOK^IBCEP5C(IBFILE,IBPRV_U_5_U_Z2_U_Z3_U_Z4_U_Z5_U_Z6,1,$G(IBFILE)=355.91)
  1.  . ; If specific care type, chk for all
  1.  . I IBOK,Z5 S IBOK=$$COMBOK^IBCEP5C(IBFILE,IBPRV_U_5_U_Z2_U_Z3_U_Z4_U_Z5_U_Z6,0,$G(IBFILE)=355.91)
  1.  . I 'IBOK K IB3559,IB35591
  1.  . I IBOK D
  1.  .. S DIR(0)=IBFILE_",.07"
  1.  .. W ! D ^DIR K DIR
  1.  .. S IBID=Y
  1.  .. I $D(DTOUT)!$D(DUOUT) K IB3559,IB35591 S IBOK=0 Q
  1.  .. S IBDR=$S(IBFILE=355.9:$S($G(IBINS):".02////"_IBINS_";",1:""),1:"")_$S($G(IBCUND):".03////"_$S(IB35591(.03):IB35591(.03),1:"*N/A*")_";",1:"")_".04////"_IB3559(.04)_";.05////"_IB3559(.05)_";.06////"_IBPTYP_$S(IBID'="":";.07////"_IBID,1:"")
  1.  .. ;
  1.  .. I $G(IBIEN) D
  1.  ... S DR=IBDR,DA=IBIEN,DIE="^IBA("_IBFILE_","
  1.  ... D ^DIE
  1.  ... I $D(Y) K IB3559,IB35591 S IBOK=0
  1.  ;
  1. NEWQ ;
  1.  I '$D(IB3559),$G(IBIEN) D  Q
  1.  . N DIR,DIK,DA,X,Y
  1.  . S DA=IBIEN,DIK="^IBA("_IBFILE_"," D ^DIK
  1.  . S DIR(0)="EA",DIR("A",1)=$S('$G(IBOK):"",1:"PROBLEM ENCOUNTERED FILING THE RECORD - ")_"RECORD NOT ADDED",DIR("A")="PRESS ENTER to continue " W ! D ^DIR K DIR
  1.  ;
  1.  ; Save this for Copy ID actions
  1.  I $G(IBIEN) D
  1.  . I IBFILE=355.91!(IBFILE=355.9&($P($G(^IBA(IBFILE,IBIEN,0)),U)["VA(200,")) D
  1.  .. N NEXTONE S NEXTONE=$$NEXTONE^IBCEP5A()
  1.  .. S ^TMP("IB_EDITED_IDS",$J,NEXTONE)=IBIEN_U_"ADD"_U_IBFILE
  1.  .. S ^TMP("IB_EDITED_IDS",$J,NEXTONE,0)=$G(^IBA(IBFILE,IBIEN,0))
  1.  Q
  1.  ;
  1. CHG(IBFILE,IBDA) ; Generic call - edit prov id
  1.  ; IBFILE = 355.9 or 355.91 (file being edited)
  1.  ; IBDA = ien in file
  1.  ;
  1.  N DIR,DIE,DA,DR,IBCUCHK,IBOK,IB0,IBOLD,X,Y,Z
  1.  F Z=1:1:3 L +^IBA(IBFILE,IBDA):5 Q:$T  W !,"Attempting to lock record"
  1.  I '$T D  G CHGQ
  1.  . W !,"RECORD LOCKED BY ANOTHER USER - TRY AGAIN LATER"
  1.  . D ENTER(.DIR)
  1.  . W ! D ^DIR K DIR W !
  1.  S (IB0,IBOLD)=$G(^IBA(IBFILE,IBDA,0))
  1.  G:IB0="" CHGQ
  1.  F Z=.04,.05,.06,.03 S IBOK=$$EDIT(IBFILE,Z,IB0,IBOLD,IBDA,0) S:IBOK="*ALL*" IBOK="" Q:$P(IBOK,U,2)  S $P(IB0,U,Z*100)=$P(IBOK,U)
  1.  I $P(IBOK,U,2) S DIR(0)="EA",DIR("A")="NO CHANGES MADE, PRESS ENTER TO CONTINUE: " W ! D ^DIR K DIR W ! G CHGQ
  1.  S IBOK=$$EDIT(IBFILE,.07,IB0,IBOLD,IBDA,1)
  1.  I '$P(IBOK,U,2) S $P(IB0,U,7)=$P(IBOK,U)
  1.  I $P(IBOK,U,2)!(IB0=IBOLD) S DIR(0)="EA",DIR("A")="NO CHANGES MADE, PRESS ENTER TO CONTINUE: " W ! D ^DIR K DIR W ! G CHGQ
  1.  S IBCUCHK=$$CUCHK^IBCEP5C(IBDA,IB0) G:IBCUCHK CHGQ
  1.  S DR=""
  1.  F Z=2,4:1:7,3 I $P(IB0,U,Z)'=$P(IBOLD,U,Z) S DR=DR_$S(DR'="":";",1:"")_(Z/100)_"///"_$S($P(IB0,U,Z)'="@":"/",1:"")_$P(IB0,U,Z)
  1.  I DR'="" D
  1.  . I IBFILE=355.91!(IBFILE=355.9&($P(IB0,U)["VA(200,")) D
  1.  .. N NEXTONE
  1.  .. S NEXTONE=$$NEXTONE^IBCEP5A()
  1.  .. S ^TMP("IB_EDITED_IDS",$J,NEXTONE)=IBDA_U_"MOD"_U_IBFILE_U_IBDA
  1.  .. S ^TMP("IB_EDITED_IDS",$J,NEXTONE,"OLD0")=IBOLD
  1.  .. S ^TMP("IB_EDITED_IDS",$J,NEXTONE,0)=IB0
  1.  . S DIE="^IBA("_IBFILE_",",DA=IBDA D ^DIE
  1. CHGQ L -^IBA(IBFILE,IBDA)
  1.  Q
  1.  ;
  1. DEL(IBFILE,IBDA,IBF) ; Delete prov specific ID's
  1.  ; IBFILE = 355.9 or 355.91 for the file
  1.  ; IBDA = ien of entry in file IBFILE
  1.  ; IBF = 1 if deleting from ins co-related options, ""
  1.  ;       from prov-related options
  1.  D DEL^IBCEP5C(IBFILE,IBDA,$G(IBF))
  1.  Q
  1.  ;
  1. EDIT(IBFILE,IBFLD,IB0,IBOLD,IBIEN,IBCK1) ; Generic edit flds
  1.  Q $$EDIT^IBCEP5D($G(IBFILE),$G(IBFLD),$G(IB0),$G(IBOLD),$G(IBIEN),$G(IBCK1))
  1.  ;
  1. SETDIR(DIR) ; Sets dir for BLUE CROSS only UB-04 form type
  1.  S DIR("B")="UB-04",$P(DIR(0),U,3)="K:Y'=1 X",DIR("?")="ONLY UB-04 FORM TYPE IS VALID FOR BLUE CROSS ID"
  1.  Q
  1.  ;
  1. ENTER(DIR) ;
  1.  S DIR(0)="EA",DIR("A")="PRESS ENTER TO CONTINUE: "
  1.  Q