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

IBEMTSCU.m

Go to the documentation of this file. 
  1. IBEMTSCU ;ALB/RFJ-print billable types for visit copay ;23 Nov 01
  1.  ;;2.0;INTEGRATED BILLING;**167,177,187,502**;21-MAR-94;Build 1
  1.  ;;Per VHA Directive 2004-038, this routine should not be modified.
  1.  Q
  1.  ;
  1. EFFDT() ;effect date Visit Copay 2
  1.  Q 3021001  ;OCT 1,2002
  1.  ;
  1. ADD(IBSTOPCD,IBEFFDT,IBBILTYP,IBDESC,IBOVER) ;  add a stop code to file 352.5
  1.  ;  ibstopcd = 3 or 6 digit stop code to add
  1.  ;  ibeffdt  = effective date, internal fileman form (ex:3011206)
  1.  ;             if effective date is not passed, it uses today (dt)
  1.  ;  ibbiltyp = billable type (B=basic, S=specialty, N=non-billable)
  1.  ;             default is non-billable if a B or S is not passed
  1.  ;  ibdesc   = description of stop code
  1.  ;  ibover   = if the code belongs to Override table
  1.  ;  returns 1 if added, -#^error if not added
  1.  ;
  1.  N D,D0,DA,DI,DIC,DIE,DLAYGO,DQ,DR,IBDA,X,Y,IBZ
  1.  ;
  1.  ;  check length of stop code
  1.  I '(($L(IBSTOPCD)=3)!($L(IBSTOPCD)=6)) Q "-1^STOP CODE "_IBSTOPCD_" NOT 3 OR 6 CHARACTERS IN LENGTH."
  1.  ;
  1.  ;  change billable type code to match set of codes in file 352.5
  1.  S IBBILTYP=$S(IBBILTYP="B":1,IBBILTYP="S":2,1:0)
  1.  ;
  1.  S (DIC,DIE)="^IBE(352.5,",DIC(0)="L",DLAYGO=352.5
  1.  ;
  1.  ;  check to see if entry is in the file
  1.  S IBDA=$O(^IBE(352.5,"AEFFDT",IBSTOPCD,-IBEFFDT,0))
  1.  I IBDA S IBZ=$G(^IBE(352.5,IBDA,0)) D  Q 1
  1.  .   S DR=""
  1.  .   ;  check to see if the correct billable type is set correctly
  1.  .   I $P(IBZ,"^",3)'=IBBILTYP S DR=".03////"_IBBILTYP_";"
  1.  .   ;  check description
  1.  .   I $P(IBZ,"^",4)'=$E(IBDESC,1,30) S DR=DR_".04////"_$E(IBDESC,1,30)
  1.  .   ;  if not, change it
  1.  .   I $L(DR) S DA=IBDA D ^DIE
  1.  ;
  1.  ;  add entry to file 352.5
  1.  S X=IBSTOPCD
  1.  S DIC("DR")=".02////"_IBEFFDT_";.03////"_IBBILTYP_";.04////"_$E(IBDESC,1,30)_";"
  1.  S:$G(IBOVER)=1 DIC("DR")=DIC("DR")_".05////1;"
  1.  D FILE^DICN
  1.  Q 1
  1.  ;
  1.  ;
  1. DIQ407(DA,DR) ;  diq call to retrieve data for dr fields in file 40.7
  1.  N D0,DIC,DIQ,DIQ2,YY
  1.  K IBSCDATA(40.7,DA)
  1.  I $G(DR)="" S DR=".01:4;"
  1.  S DIQ(0)="IE",DIC="^DIC(40.7,",DIQ="IBSCDATA" D EN^DIQ1
  1.  Q
  1.  ;
  1.  ;0 - active
  1. ISINACT(IBCODE) ;
  1.  Q:$L(IBCODE)=6 $$INACTIVE($E(IBCODE,1,3))+$$INACTIVE($E(IBCODE,4,6))
  1.  Q $$INACTIVE(IBCODE)
  1.  ;
  1. INACTIVE(IBSTCODE) ;  return 1 if inactive in file 40.7
  1.  ;  also, return ibscdata(da for stop code entries in 40.7)
  1.  N DA,IBSCDATA,RESULT
  1.  ;
  1.  ;  default is inactive
  1.  S RESULT=1
  1.  ;
  1.  S DA=0 F  S DA=$O(^DIC(40.7,"C",IBSTCODE,DA)) Q:'DA  D
  1.  . D DIQ407(DA,2)
  1.  . I 'IBSCDATA(40.7,DA,2,"I") S RESULT=0 Q
  1.  . ;IB*502 ticket 862861 only prevent selection if visit date is after the inactive date
  1.  . I IBFR<+$G(IBSCDATA(40.7,DA,2,"I")) S RESULT=0
  1.  ;
  1.  Q RESULT
  1.  ;
  1.  ;
  1. ASK() ; ask if the user wants to enter a stop code or select a clinic
  1.  ; return will be what entry point to use
  1.  N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
  1.  S DIR(0)="S^C:Clinic;S:Stop Code" D ^DIR
  1.  Q $S(Y="C":"C",Y="S":"S",1:"")
  1.  ;
  1. ASKSCODE(IBPROMPT) ;  ask and return selected stop code from file 352.5
  1.  ;  ibprompt = optional prompt to display
  1.  ;
  1.  N DIC,DILN,I,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
  1.  S DIC="^IBE(352.5,",DIC(0)="QEAM"
  1.  S DIC("A")="Select OUTPATIENT VISIT STOP CODE: "
  1.  I $G(IBPROMPT)'="" S DIC("A")=IBPROMPT
  1.  S DIC("S")="I $$STOPSCRN^IBEMTSCU(Y)"
  1.  ;
  1.  W ! D ^DIC
  1.  I Y<1 Q -1
  1.  Q +Y
  1.  ;
  1.  ;
  1. STOPSCRN(IBX) ; screens out so only active and current ones are selectable
  1.  ;
  1.  ; if we have no from date, all are selectable
  1.  I '$G(IBFR) Q 1
  1.  ;
  1.  N IBZ,IBAX,IBS,IBEFFDT
  1.  S IBZ=$G(^IBE(352.5,IBX,0)),IBS=$P(IBZ,"^")
  1.  ;
  1.  ; is the effective date for this entry in the future?
  1.  I $P(IBZ,"^",2)>IBFR Q 0
  1.  ;
  1.  ;  get the effective date for stop code and visit date
  1.  S IBEFFDT=$O(^IBE(352.5,"AEFFDT",IBS,-(IBFR+.1)))
  1.  I 'IBEFFDT Q 0
  1.  ;
  1.  ;  get the billable entry to compare
  1.  S IBAX=$O(^IBE(352.5,"AEFFDT",IBS,IBEFFDT,0))
  1.  ;
  1.  Q $S(IBX=IBAX:1,1:0)
  1.  ;
  1. ASKSC(IBVISTDT) ; ask for a clinic to look up the stop code
  1.  ; it will prompt for a clinic selection, and return the stop
  1.  ; code number in 352.5 associated with the clinic
  1.  N DIC,X,Y,IB407,IBEFDT,IBCLIN
  1.  S DIC="^SC(",DIC(0)="AEMQZ",DIC("A")="Select CLINIC: ",DIC("S")="I $P(^(0),U,3)=""C""" D ^DIC Q:Y<1 -1
  1.  S IBCLIN=+Y
  1.  ;primary
  1.  S IB407=$P(Y(0),"^",7)
  1.  S IBCODE1=$$GETCODE(IB407)
  1.  ; if < eff date
  1.  Q:IBVISTDT<$$EFFDT() $$GET3525(+IBCODE1,0,IBVISTDT)
  1.  ;secondary
  1.  ; get the secondary stop code value
  1.  S IBCODE2=$$GETCRED(IBCLIN)
  1.  ;return proper IEN of #352.5
  1.  Q +$$GET3525(IBCODE1,IBCODE2,IBVISTDT)
  1.  ;
  1.  ;
  1. GETTYPE(IBSTOPCD,IBVISTDT) ;  lookup billable type
  1.  ;  input ibstopcd = stop code (.01 field entry in file 352.5)
  1.  ;        ibvistdt = visit date in fileman format
  1.  ;
  1.  ;  returns     -1 = stop code/effective date not found or defined
  1.  ;               0 = non-billable
  1.  ;               1 = basic rate
  1.  ;               2 = specialty rate
  1.  ;
  1.  N DA,IBEFFDT,RESULT
  1.  ;
  1.  ;  get the effective date for stop code and visit date
  1.  S IBEFFDT=$O(^IBE(352.5,"AEFFDT",IBSTOPCD,-(IBVISTDT+.1)))
  1.  I 'IBEFFDT Q -1
  1.  ;
  1.  ;  get the billable type
  1.  S DA=$O(^IBE(352.5,"AEFFDT",IBSTOPCD,IBEFFDT,0))
  1.  I 'DA Q -1
  1.  ;
  1.  ;  get the billable type
  1.  S RESULT=+$P($G(^IBE(352.5,DA,0)),"^",3)
  1.  Q RESULT
  1.  ;
  1.  ;
  1. GETSC(IBSL,IBVISTDT) ;  return the ien of the entry in file 352.5.
  1.  ;  ibsl is the clinic stop code in 409.68.  find the matching
  1.  ;  entry in file 352.5.  the 352.5 entry is populated in the 350 field
  1.  ;  for reference using the ibstopda variable
  1.  ;    input ibsl = 409.68:ien
  1.  N IB407,IBCLIN,IBCODE1,IBCODE2
  1.  I $P(IBSL,":")'=409.68 Q ""
  1.  ;primary
  1.  ;this is the ien for file 40.7 (dbia402)
  1.  S IB407=+$P($G(^SCE(+$P(IBSL,":",2),0)),"^",3)
  1.  ;get the primary stop code value
  1.  S IBCODE1=+$$GETCODE(IB407)
  1.  ;if < eff date
  1.  Q:IBVISTDT<$$EFFDT() $$GET3525(+IBCODE1,0,IBVISTDT)
  1.  ;secondary
  1.  ;get clinic(#44) pointer from #409.68
  1.  S IBCLIN=+$P($G(^SCE(+$P(IBSL,":",2),0)),"^",4)
  1.  ;get the secondary stop code value
  1.  S IBCODE2=+$$GETCRED(IBCLIN)
  1.  ;return proper IEN of #352.5
  1.  Q $$GET3525(+IBCODE1,+IBCODE2,IBVISTDT)
  1.  ;
  1.  ;apply business rules, select appropr. code in #352.5 and return its IEN
  1.  ;if  not found then return ""
  1. GET3525(IBCODE1,IBCODE2,IBVISTDT) ;
  1.  Q:+IBCODE1=0 ""  ;must be defined as a required field in #44
  1.  Q:$L(+IBCODE1)'=3!(IBCODE1<0) ""
  1.  I $L(+IBCODE2)'=3!(IBCODE2<0) S IBCODE2=0
  1.  N IB6DIG
  1.  N IBEFDT1,IBIEN1,IBOVER1,IBTYPE1
  1.  N IBEFDT2,IBIEN2,IBOVER2,IBTYPE2
  1.  S (IBIEN1,IBIEN2,IBOVER1,IBOVER2)=0
  1.  ;------ find appropriate ien in file #352.5
  1.  S IB6DIG=$S(IBCODE2>0:IBCODE1_IBCODE2,1:IBCODE1)
  1.  ;in the #352.5 with appropriate eff date?
  1.  S IBEFDT1=+$O(^IBE(352.5,"AEFFDT",IB6DIG,-(IBVISTDT+.1)))
  1.  ;
  1.  ;A) if found and it is 6 or 3 digit code
  1.  I IBEFDT1 D  Q:IBIEN1>0 IBIEN1
  1.  . ;get the entry in 352.5 
  1.  . S IBIEN1=+$O(^IBE(352.5,"AEFFDT",IB6DIG,IBEFDT1,0))
  1.  ;
  1.  ;B) if not found and it is 3 digit - return nothing, BASIC applies
  1.  I +IBCODE2=0 Q ""
  1.  ;
  1.  ;C) if not found and it is 6 digit - try each separately
  1.  ;-- primary code
  1.  ;in the #352.5 "override" tables with appropriate eff date?
  1.  S IBEFDT1=+$O(^IBE(352.5,"AEFFDT",IBCODE1,-(IBVISTDT+.1)))
  1.  I IBEFDT1 D
  1.  . ;get the entry in 352.5 
  1.  . S IBIEN1=+$O(^IBE(352.5,"AEFFDT",IBCODE1,IBEFDT1,0))
  1.  . Q:IBIEN1=0
  1.  . S IBOVER1=+$P($G(^IBE(352.5,IBIEN1,0)),"^",5)
  1.  . S IBTYPE1=+$P($G(^IBE(352.5,IBIEN1,0)),"^",3)
  1.  ;-- secondary code
  1.  ;in the #352.5 "override" tables with appropriate eff date?
  1.  S IBEFDT2=+$O(^IBE(352.5,"AEFFDT",IBCODE2,-(IBVISTDT+.1)))
  1.  I IBEFDT2 D
  1.  . ;get the entry in 352.5 
  1.  . S IBIEN2=+$O(^IBE(352.5,"AEFFDT",IBCODE2,IBEFDT2,0))
  1.  . Q:IBIEN2=0
  1.  . S IBOVER2=+$P($G(^IBE(352.5,IBIEN2,0)),"^",5)
  1.  . S IBTYPE2=+$P($G(^IBE(352.5,IBIEN2,0)),"^",3)
  1.  ;
  1.  ; If not found in override tables 
  1.  ; - AND primary is not in #352.5 then return nothing, BASIC applies
  1.  ; - AND primary is in #352.5 then return IBIEN1
  1.  I IBOVER1=0,IBOVER2=0 Q $S(IBIEN1>0:IBIEN1,1:"")
  1.  ;
  1.  I IBOVER1=0,IBOVER2'=0 Q +IBIEN2
  1.  ;
  1.  I IBOVER1'=0,IBOVER2=0 Q +IBIEN1
  1.  ;
  1.  ; If IBOVER1'=0,IBOVER2'=0
  1.  I IBTYPE1=0 Q +IBIEN1  ;NON
  1.  I IBTYPE2=0 Q +IBIEN2  ;NON
  1.  I IBTYPE1=2 Q +IBIEN1  ;SPEC
  1.  I IBTYPE2=2 Q +IBIEN2  ;SPEC
  1.  Q +IBIEN1  ;BASIC
  1.  ;
  1.  ;
  1. OPT ;  perform outpatient copay edits for visits after 11/29/01
  1.  ;  called from IBECEA3
  1.  ;
  1.  ;  return IBSTOPDA (if selected) to be stored in file 350
  1.  K IBSTOPDA,IBANS
  1.  ;
  1.  ;  ask selection by clinic or stop code
  1.  S IBANS=$$ASK I '$L(IBANS) W !!,"Charge NOT added." S IBY=-1 Q
  1.  ;
  1.  ;  ask clinic stop to calc charges
  1.  S IBSTOPDA=+$S(IBANS="S":$$ASKSCODE,1:$$ASKSC(IBFR))
  1.  I IBSTOPDA<0 S IBY=-1 W !!,"Charge NOT added." K IBSTOPDA Q
  1.  ;
  1.  ;  user selected a non-billable clinic stop
  1.  I IBSTOPDA>0,'$P($G(^IBE(352.5,IBSTOPDA,0)),"^",3) W !?5,"********** This is a NON-BILLABLE Clinic Stop **********",!?5,"Select an active billable clinic stop or press RETURN to exit." G OPT
  1.  ;  user selected an inactive stop code
  1.  I IBSTOPDA>0,$$ISINACT($P($G(^IBE(352.5,IBSTOPDA,0)),"^")) W !?5,"********** This is a INACTIVE Clinic Stop in file #40.7 **********",!?5,"Select an active billable clinic stop or press RETURN to exit." G OPT
  1.  ;  IB*502 prevent selection of Secondary stop codes
  1.  I IBSTOPDA>0,$$ISSEC($P($G(^IBE(352.5,IBSTOPDA,0)),"^")) W !?5,"********** This is a SECONDARY Clinic Stop in file #40.7 **********",!?5,"Select an active billable clinic stop or press RETURN to exit." G OPT
  1.  ;  *** get the charge ***
  1.  ;  return IBTO, IBUNIT, IBEVDA, IBCHG for processing in IBECEAU3
  1.  N IBDT,IBTYPE,IBX
  1.  S (IBDT,IBTO)=IBFR       ;visit date
  1.  S IBX="O" ;O for outpatient
  1.  S IBUNIT=1,IBEVDA="*"
  1.  S IBTYPE=1 ;BASIC by default
  1.  S:IBSTOPDA>0 IBTYPE=$P(^IBE(352.5,IBSTOPDA,0),"^",3)  ;type of charge, basic or specialty
  1.  D TYPE^IBAUTL2
  1.  I IBY<0 Q
  1.  ;
  1.  W !!,"Charge to be billed under the ",$$TYPE^IBEMTSCR($P($G(^IBE(352.5,IBSTOPDA,0)),"^",3))," Rate --> $",$J(IBCHG,0,2)
  1.  Q
  1.  ;
  1.  ;Get credit pair (secondary code) from #44
  1. GETCRED(IBCLIN) ;
  1.  N IB407
  1.  ; get credit pair (secondary stop code pointer) from #44
  1.  S IB407=+$P($G(^SC(IBCLIN,0)),"^",18)
  1.  ; if IB407 is defined, get the stop code in IBSCDATA(40.7,IB407,1,"E")
  1.  Q $$GETCODE(IB407)
  1.  ;
  1. GETCODE(IB407) ;
  1.  ; get the stop code in IBSCDATA(40.7,IB407,1,"E")
  1.  N IBCODE,IBSCDATA
  1.  S IBCODE=0
  1.  I IB407'=0 D DIQ407(IB407,1) D
  1.  . I $G(IBSCDATA(40.7,IB407,1,"E"))="" Q
  1.  . S IBCODE=+$G(IBSCDATA(40.7,IB407,1,"E"))
  1.  . S:$L(+IBCODE)'=3!(IBCODE<0) IBCODE=0
  1.  Q IBCODE
  1.  ;
  1. ISSEC(IBCODE) ;check if the code has secondary restriction type in DSS IB*502
  1.  N DA,IBSCDATA,IBRESULT
  1.  ;
  1.  ;  default OK
  1.  S IBRESULT=0
  1.  ;
  1.  S DA=0 F  S DA=$O(^DIC(40.7,"C",IBCODE,DA)) Q:'DA  D
  1.  . D DIQ407(DA,"5:6;")
  1.  . I $G(IBSCDATA(40.7,DA,5,"I"))="S" D
  1.  .. I $G(IBSCDATA(40.7,DA,6,"I"))<=IBFR S IBRESULT=1
  1.  ;
  1.  Q IBRESULT
  1.  ;