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

IBAMTC2.m

Go to the documentation of this file.
  1. IBAMTC2 ;ALB/CJM - INTEGRATED BILLING, CLEANUP OF UNCLOSED EVENTS, UNPASSED CHARGES ; 04-APRIL-1992
  1. ;;2.0;INTEGRATED BILLING;**132,176**;21-MAR-94
  1. ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1. ;
  1. MAIN ;
  1. N IBAGE,IBFREQ,IBCHG,DFN,IBN,IBND,IBSL,IBDISC,DIE,DR,DA,IBQUIT,IBPASS,IBOLD,IBDATE,IBDUZ S IBDUZ=$G(DUZ)
  1. D NOW^%DTC S IBDATE=X
  1. S IBAGE=44,IBFREQ=15 ; age of unpassed charges to report, frequency
  1. ; loop through all incomplete entries in file 350
  1. N IBFLLTC
  1. S IBN="" F S IBN=$O(^IB("AC",1,IBN)) Q:'IBN S IBND=$G(^IB(IBN,0)) D
  1. .Q:($P(IBND,"^",5)'=1)!($P(IBND,"^",16)']"")
  1. .I $P(IBND,"^",16)=IBN S IBFLLTC="" D Q:IBFLLTC="L"
  1. ..;
  1. ..N IBDISC,IBSL,VAIN,VAINDT,IBLDT D DISC Q:+IBDISC=0
  1. ..S DFN=$P(IBND,"^",2),VAINDT=IBDISC D INP^VADPT S IBFLLTC=$P($$TREATSP^IBAECU2($P($G(^DIC(45.7,+VAIN(3),0)),U,2)),"^",1)
  1. ..S IBLDT=$$LASTMJ^IBAECU() I IBLDT>0,$E(IBDISC,1,5)<$E(IBLDT,1,5),IBFLLTC="L" D CLOSE
  1. .I $P(IBND,"^",16)=IBN D
  1. ..D EVENT
  1. .E D CHARGE
  1. Q
  1. EVENT ; closes events if the patient was discharged
  1. S (IBPASS,IBQUIT)=0
  1. D DISC I IBDISC D CLOSE D:'IBQUIT FNDCHGS,PASS:IBCHG,BULLET1^IBAMTC3
  1. Q
  1. DISC ; gets the discharge date
  1. S IBDISC="",IBSL=$P(IBND,"^",4)
  1. I $P(IBSL,":")=405 S IBDISC=$P(IBSL,":",2) S:IBDISC]"" IBDISC=$P($G(^DGPM(IBDISC,0)),"^",17)
  1. S:IBDISC IBDISC=($P($G(^DGPM(IBDISC,0)),"^")\1)
  1. Q
  1. CLOSE ;
  1. S IBQUIT=1
  1. L +^IB(IBN):3 I $T D
  1. .S IBQUIT=0
  1. .S DIE="^IB(",DA=IBN,DR=".05////2"
  1. .D ^DIE L -^IB(IBN)
  1. Q
  1. FNDCHGS ;
  1. N I S IBCHG="" F I=1:1 S IBCHG=$O(^IB("ACT",IBN,IBCHG)) Q:'IBCHG S IBCHG(I)=IBCHG
  1. S IBCHG=(I-1)
  1. Q
  1. PASS ; pass the charges if they appear correct, complete, and can be locked
  1. S IBPASS=0
  1. N IBI,IBNOS,IBADMIT S DFN=$P(IBND,"^",2),IBADMIT=($P(IBND,"^",17)\1)
  1. Q:+$$MVT^DGPMOBS($P(IBSL,":",2))
  1. I IBDISC=$P(IBND,"^",17) Q:$P(IBND,"^",18)'=IBDISC
  1. E S X1=$P(IBND,"^",18),X2=1 D C^%DTC Q:X'=IBDISC
  1. S IBPASS=1 F IBI=1:1:IBCHG L +^IB(IBCHG(IBI)):1 S IBPASS=$T Q:'IBPASS I ($P($G(^IB(IBCHG(IBI),0)),"^",15)>IBDISC)!($P($G(^IB(IBCHG(IBI),0)),"^",14)<IBADMIT) S IBPASS=0 Q
  1. I IBPASS N IBN F IBI=1:1:IBCHG S IBNOS=IBCHG(IBI),IBY=1 D FILER^IBAUTL5 D:IBY<1 ^IBAERR1
  1. F IBI=1:1:IBCHG L -^IB(IBCHG(IBI))
  1. Q
  1. ;
  1. CHARGE ; if the charge is old send a bulletin
  1. N IBWHEN S IBWHEN=$P($G(^IB(IBN,1)),"^",2)
  1. S X2=IBWHEN,X1=IBDATE D ^%DTC
  1. S IBOLD=(+$FN(X,"T")) I IBOLD>IBAGE,X#IBFREQ=0 D BULLET2^IBAMTC3
  1. Q