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

IBAUTL.m

Go to the documentation of this file.
  1. IBAUTL ;ALB/AAS - INTEGRATED BILLING APPLICATION UTILITIES ; 14-FEB-91
  1. ;;2.0;INTEGRATED BILLING;**93,156,347,429,563**;21-MAR-94;Build 12
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. ;
  1. COST ; - find charges for transaction type, when only one
  1. N IBD,IBN,IB K X1
  1. S IBD=-($G(IBEFDT,DT)+.9)
  1. F S IBD=$O(^IBE(350.2,"AIVDT",DA,IBD)) Q:'IBD S IBN=0 F S IBN=$O(^IBE(350.2,"AIVDT",DA,IBD,IBN)) Q:'IBN S IB=$G(^IBE(350.2,IBN,0)) I IB]"",$$TIEROK^IBAUTL(IB),'$P(IB,"^",5)!($P(IB,"^",5)>$G(IBEFDT,DT)) S X1=$P(IB,"^",4) G COSTQ
  1. COSTQ S X1=+$G(X1)
  1. I 'X1,$G(IBTIER),$D(^IBE(350.2,"AC",DA,2)) S IBTIER=2 G COST ;default foced tier
  1. I 'IBN S Y="-1^IB029" Q
  1. I $L($G(^IBE(350.2,IBN,20))) X ^(20) I S X1=X1+$P($G(^IBE(350.2,IBN,0)),"^",6)
  1. Q
  1. TIEROK(IB) ; - if there is a tier present, make sure it matches
  1. ; if not present it's OK
  1. ; IB = zero node of 350.2 from COST above
  1. I '$D(IBTIER) Q 1
  1. I $P(IB,"^",7)=IBTIER Q 1
  1. Q 0
  1. ;
  1. FY I $D(X) S IBAFY=$$FY^IBOUTL(X)
  1. Q
  1. ;
  1. PTL ; - parent trace logic
  1. ; - input in x resulting from field from file 350
  1. ; - output in y=1 if found, -1^error message if not found
  1. ; - y(0) = zeroth node of top level
  1. ; - y(1) = zeroth node of second level
  1. ; - y(n) = zeroth node of nth level
  1. ;
  1. K Y
  1. S Y=1 I '+X!'($D(^DIC(+X,0,"GL"))) S Y="-1^IB004" G PTLQ
  1. I +X=52 G PHAPI
  1. S IBAGL=^DIC(+X,0,"GL")
  1. I '$D(@(IBAGL_$P($P(X,";",1),":",2)_",0)")) S Y="-1^IB005" G PTLQ
  1. ;
  1. ; This naked reference should be set to the original data source that
  1. ; is causing this charge to be created. The data source will be one of
  1. ; many different data sources that will generate patient charges.
  1. S Y(0)=^(0)
  1. ;
  1. F IBJJ=2:1 S IBII=$P(X,";",IBJJ) Q:IBII="" D PTL1
  1. PTLQ K IBAGL,IBII,IBJJ,IBMIN
  1. Q
  1. ;
  1. PTL1 ; - find y(n) of sublevels
  1. ; Call in here with a FOR loop to go each level deeper. This will
  1. ; setup the subsripts in Y for all the data elements that go into
  1. ; causing this charge to be created. It looks in the original data
  1. ; source file as approprite to obtain the information. The naked
  1. ; reference should be the last data level in the data source appropriate
  1. ; data source file last looked up.
  1. ;
  1. S IBMIN=$P(IBII,":") I IBMIN="" S Y="-1^IB006" Q
  1. I '$D(^(IBMIN,$P(IBII,":",2),0)) S Y="-1^IB006" Q
  1. ;I '$D(^(+IBII,$P(IBII,":",2),0)) S Y="-1^IB006" Q
  1. S Y(IBJJ-1)=^(0)
  1. Q
  1. ;
  1. CHKX ; - check input x
  1. ; - piece 1 = service and exists
  1. ; - peice 2 = patient and exists
  1. ; - piece 3 = action type
  1. ; - piece 4 = user duz
  1. S DFN=$P(X,"^",2),IBSERV=+IBSAVX
  1. I $S('DFN:1,'$D(^DPT(DFN,0)):1,1:0) S Y="-1^IB002" G CHKXQ ;patient pointer bad
  1. I $S('IBSERV:1,'$D(^DIC(49,IBSERV,0)):1,1:0) S Y="-1^IB003" G CHKXQ ;service pointer bad
  1. I IBTAG=1 G CHKXQ
  1. S IBDUZ=$P(IBSAVX,"^",4) I $S('IBDUZ:1,'$D(^VA(200,IBDUZ,0)):1,1:0) S Y="-1^IB007" G CHKXQ
  1. I IBTAG=3 G CHKXQ
  1. S IBATYP=$P(IBSAVX,"^",3) I $S('IBATYP:1,'$D(^IBE(350.1,IBATYP,0)):1,1:0) S Y="-1^IB008"
  1. CHKXQ Q
  1. ;
  1. SITE ; - calculate site from site parameters
  1. ; - output ibsite = station number
  1. ; = ibfac = pointer to institution file
  1. I '$D(^IBE(350.9,1,0)) S Y="-1^IB016" Q
  1. S IBFAC=$P(^IBE(350.9,1,0),"^",2),IBSITE=$S('$D(^DIC(4,IBFAC,99)):"",1:+^(99)) I IBSITE<1 S Y="-1^IB009"
  1. Q
  1. ;
  1. ADD ; - add new entry to ^ib
  1. ;
  1. N %DT,IBYCHK
  1. L +^IB(0):10 I '$T S Y="-1^IB014" G ADDQ
  1. S X=$P($S($D(^IB(0)):^(0),1:"^^-1"),"^",3)+1 L -^IB(0) I 'X S Y="-1^IB015" G ADDQ
  1. K DD,DO,DIC,DR S DIC="^IB(",DIC(0)="L",DLAYGO=350
  1. F X=X:1 L:$D(IBN1) -^IB(IBN1) I X>0,'$D(^IB(X)) S IBN1=X L +^IB(IBN1):1 I $T,'$D(^IB(X)) S DINUM=X,X=+IBSITE_X D FILE^DICN I +Y>0 Q
  1. S IBN=+Y,DIE="^IB(",DA=IBN,DR=".02////"_$S($D(DFN):DFN,1:"")_";.03////"_$S($D(IBATYP):IBATYP,1:"")_";.05////1;12///NOW" D
  1. . N Y D ^DIE K DA,DR,DIE I $D(Y) S IBYCHK=Y
  1. L -^IB(IBN1)
  1. S Y=$S('$D(IBYCHK):1,1:"-1^IB028")
  1. ;
  1. ADDQ K DO,DD,DINUM,DIC,IBN1 Q
  1. ;
  1. ARPARM N X S X=DT
  1. D SITE,FY,NOW^%DTC S IBNOW=%
  1. Q
  1. BILLNO ; -get open bill number
  1. I '$G(IBTOTL) S (IBIL,IBTRAN)="" G BILLQ
  1. S IBARTYP=$S($D(^IBE(350.1,+IBATYP,0)):$P(^(0),"^",3),1:"")
  1. S X=IBSITE_"^"_IBSERV_"^"_IBARTYP_"^"_DFN_";DPT("_"^"_IBAFY_"^"_$S($D(IBTOTL):IBTOTL,1:0)_"^"_$S($D(IBDUZ):IBDUZ,$D(DUZ):DUZ,1:0)_"^"_$P(IBNOW,".",1) D ^PRCASER I +Y<1 G BILLQ
  1. S IBIL=$P(Y,"^",2),IBTRAN=$P(Y,"^",3) I IBIL="" S Y="-1^IB011" G BILLQ
  1. S IBTRAN=$S(IBTRAN>0:IBTRAN,1:"")
  1. BILLQ Q
  1. ;
  1. PHAPI ;
  1. ;This is alternate code for Parent Trace Logic
  1. ; to deal with the Pharmacy Encapsulation of Prescription File (#52)
  1. ;
  1. N IBRFL,IBXX,IBPT,IBRX,IBY
  1. S IBXX=X,IBY=1
  1. S IBRX=$P($P(IBXX,";"),":",2)
  1. S IBPT=$$FILE^IBRXUTL(IBRX,2),IBY(0)=$$RXZERO^IBRXUTL(IBPT,IBRX) I IBY(0)="" S IBY="-1^IB005" G PHAPIQ
  1. I $P(IBXX,";",2)="" G PHAPIQ ; original fill being billed
  1. S IBRFL=$P($P(IBXX,";",2),":",2),IBY(1)=$$ZEROSUB^IBRXUTL(IBPT,IBRX,IBRFL)
  1. I IBY(1)="" S IBY="-1^IB006" G PHAPIQ
  1. ;
  1. PHAPIQ ;
  1. S:$G(IBY)]"" Y=IBY
  1. S:$G(IBY(0))]"" Y(0)=IBY(0)
  1. S:$G(IBY(1))]"" Y(1)=IBY(1)
  1. Q
  1. ;
  1. RXTIER(DFN,IBRX,IBEFDT) ; - look up the tier of the prescription
  1. ; returns the tier level of the specified prescription
  1. ; the existence of the IBTIER variable means it is already determined elsewhere and we'll just use that value
  1. ; default tier is always 2
  1. ;
  1. N IBR
  1. I $D(IBTIER) Q IBTIER
  1. I '$G(IBRX) Q 2
  1. I $T(CPTIER^PSNAPIS)="" Q 2
  1. S IBR=$$RXZERO^IBRXUTL(DFN,IBRX)
  1. S IBR=$S($P(IBR,"^",6):$$DRUGF^IBRXUTL1($P(IBR,"^",6),22),1:0)
  1. S IBR=$S(IBR:$$CPTIER^PSNAPIS(+IBR,IBEFDT),1:2)
  1. I IBR="" S IBR=2
  1. Q +IBR
  1. ;
  1. ARCOST(DFN,DA,IBX) ; api for AR to look up the charge of a med
  1. ; input: DFN = patient pointer
  1. ; DA = 350.1 pointer
  1. ; IBX = Rx IEN
  1. ; output: returns the single 30 day supply charge amount
  1. ; assumption, since AR is all about today, DT is used for the date
  1. ;
  1. N IBEFDT,X1,IBTIER
  1. S IBTIER=$$RXTIER(DFN,IBX,DT)
  1. S IBX=":"_IBX
  1. D COST
  1. Q X1
  1. ;