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