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

IBTUTL1.m

Go to the documentation of this file. 
  1. IBTUTL1	;ALB/AAS - CLAIMS TRACKING UTILITY ROUTINE ; 21-JUN-93
  1. 	;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
  1. 	;;Per VHA Directive 10-93-142, this routine should not be modified.
  1. 	;
  1. OPT(DFN,IBETYP,IBTDT,ENCTR,IBRMARK,IBVSIT)	; -- add outpatient care entries
  1. 	; -- input   dfn  := patient pointer to 2
  1. 	;          ibetyp := pointer to type entry in 356.6
  1. 	;          ibtdt  := episode date
  1. 	;          enctr  := pointer to opt. encounter file (optional)
  1. 	;        ibrmark  := text of reason not billable (optional)
  1. 	;         ibvsit  := pointer to visit file (optional)
  1. 	;
  1. 	N X,Y,DA,DR,DIE,DIC
  1. 	I $G(IBETYP) S IBETYP=$O(^IBE(356.6,"AC",2,0))
  1. 	S X=$O(^IBT(356,"APTY",DFN,IBETYP,IBTDT,0)) I X S IBTRN=X G OPTQ
  1. 	D ADDT^IBTUTL
  1. 	I '$G(ENCTR) I $P($G(^DPT(DFN,"S",IBTDT,0)),"^",20) S ENCTR=$P(^(0),"^",20)
  1. 	S DA=IBTRN,DIE="^IBT(356,"
  1. 	I IBTRN<1 G OPTQ
  1. 	L +^IBT(356,+IBTRN):10 I '$T G OPTQ
  1. 	S DR=".02////"_$G(DFN)_";.03////"_$G(IBVSIT)_";.04////"_$G(ENCTR)_";.06////"_+IBTDT_";.18////"_IBETYP_";.2////1;.24////"_$$INSURED^IBCNS1(DFN)_";1.01///NOW;1.02////"_DUZ_";.17////"_$$EABD^IBTUTL(IBETYP)
  1. 	I $G(IBRMARK)'="" S DR=DR_";.19///"_IBRMARK
  1. 	D ^DIE K DA,DR,DIE
  1. 	L -^IBT(356,+IBTRN)
  1. OPTQ	Q
  1. 	;
  1. REFILL(DFN,IBETYP,IBTDT,IBRXN,IBRXN1,IBRMARK)	; -- add refill
  1. 	; -- input   dfn   := patient pointer to 2
  1. 	;          ibetyp  := pointer to type entry in 356.6
  1. 	;          ibtdt   := episode date (refill date)
  1. 	;          ibrxn   := pointer to 52
  1. 	;          ibrxn1  := refill multiple entry
  1. 	;          ibrmark := non billable reason if unsure
  1. 	;
  1. 	N X,Y,DA,DR,DIE,DIC
  1. 	S X=$O(^IBT(356,"APTY",DFN,IBETYP,IBTDT,0)) I X S IBTRN=X G REFILLQ
  1. 	D ADDT^IBTUTL
  1. 	I IBTRN<1 G REFILLQ
  1. 	S DA=IBTRN,DIE="^IBT(356,"
  1. 	L +^IBT(356,+IBTRN):10 I '$T G REFILLQ
  1. 	S DR=".02////"_$G(DFN)_";.06////"_+IBTDT_";.08////"_IBRXN_";.1////"_IBRXN1_";.18////"_IBETYP_";.2////1;.24////"_$$INSURED^IBCNS1(DFN)_";1.01///NOW;1.02////"_DUZ_";.17////"_$$EABD^IBTUTL(IBETYP)
  1. 	I $G(IBRMARK)'="" S DR=DR_";.19///"_IBRMARK
  1. 	D ^DIE K DA,DR,DIE
  1. 	L -^IBT(356,+IBTRN)
  1. REFILLQ	Q
  1. 	;
  1. PRO(DFN,IBTDT,IBPRO,IBRMARK)	; -- add prosthetic entries
  1. 	; -- input   dfn  := patient pointer to 2
  1. 	;          ibetyp := pointer to type entry in 356.6
  1. 	;          ibtdt  := episode date
  1. 	;
  1. 	N X,Y,DA,DR,DIE,DIC,IBETYP
  1. 	;S IBETYP=$O(^IBE(356.6,"ACODE",4,0))
  1. 	S IBETYP=$O(^IBE(356.6,"AC",3,0)) ;prosthetics type
  1. 	S X=$O(^IBT(356,"APRO",IBPRO,0)) I X S IBTRN=X G PROQ
  1. 	D ADDT^IBTUTL
  1. 	I IBTRN<1 G PROQ
  1. 	S DA=IBTRN,DIE="^IBT(356,"
  1. 	L +^IBT(356,+IBTRN):10 I '$T G PROQ
  1. 	S DR=".02////"_$G(DFN)_";.06////"_+IBTDT_";.09////"_IBPRO_";.18////"_IBETYP_";.2////1;.24////"_$$INSURED^IBCNS1(DFN)_";1.01///NOW;1.02////"_DUZ_";.17////"_$$EABD^IBTUTL(IBETYP)
  1. 	I $G(IBRMARK)'="" S DR=DR_";.19///"_IBRMARK
  1. 	D ^DIE K DA,DR,DIE
  1. 	L -^IBT(356,+IBTRN)
  1. PROQ	Q
  1. 	;
  1. PT(DFN)	; -- format patient name - last 4 for output
  1. 	S Y="" I '$G(DFN) G PTQ
  1. 	I '$D(VA("PID")) D PID^VADPT
  1. 	S Y=$E($P($G(^DPT(DFN,0)),"^"),1,20)_" "_$E($G(^(0)),1)_VA("BID")
  1. PTQ	Q Y
  1. 	;
  1. PRODATA(IBDA)	; -- return data from prosthetics file
  1. 	N IBDA0,DA,DIC,DIE,DR
  1. 	K IBRMPR ; only one array at a time
  1. 	I '$G(IBDA) G PRODAQ
  1. 	S IBDA0=$G(^RMPR(660,+IBDA,0))
  1. 	G:IBDA0="" PRODAQ
  1. DIQ	S DIC="^RMPR(660,",DR=".01;1:5;7;10;12:17;24"
  1. 	S DIQ="IBRMPR",DIQ(0)="E",DA=IBDA
  1. 	D EN^DIQ1
  1. PRODAQ	Q