IBATUTL ;LL/ELZ - TRANSFER PRICING UTILITES ; 3-SEP-1998
;;2.0;INTEGRATED BILLING;**115,266,347,389**;21-MAR-94;Build 6
;;Per VHA Directive 2004-038, this routine should not be modified.
;
SL() ; -- called to select a patient or enrolled facility
N X,Y,DTOUT,DUOUT,DIRUT,DIROUT,DIR
S DIR(0)="350.9,10.01",DIR("A")="Select Patient or Enrolled Facility"
D ^DIR
Q Y
SLPT() ; -- called to select a patient, returns 0 or patient dfn
N X,Y,DIC,DTOUT,DUOUT
S DIC="^IBAT(351.6,",DIC(0)="AEMQ" D ^DIC
Q $S(+Y>0:+Y,1:0)
;
SLDR(Q) ; -- called to select a date range
; defaults are from=T-365, to=TODAY
; output IBBDT, IBEDT, quit returns 0 if not valid
;
N DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y,IBDT
S DIR(0)="DA^:NOW:EX",DIR("A")="Select FROM DATE: "
S:$D(Q) DIR("?")=Q
D ^DIR G:'Y SLDRQ S IBDT=+Y
S DIR(0)="DA^"_+Y_":NOW:EX",DIR("A")=" TO: "
D ^DIR
S:Y IBEDT=+Y+.999999,IBBDT=IBDT G SLDRQ
SLDR1Y() ; -- called to select a date range w/1y past default
; defaults are from=T-365, to=TODAY
; output IBBDT, IBEDT, quit returns 0 if not valid
;
N DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y,IBDT
S DIR(0)="DA^:NOW:EX",DIR("A")="Select FROM DATE: "
S DIR("B")=$$DAT2^IBOUTL($$FMADD^XLFDT(DT,-365)) D ^DIR
G:'Y SLDRQ S IBDT=+Y
S DIR(0)="DA^"_+Y_":NOW:EX",DIR("A")=" to: "
S DIR("B")=$$DAT2^IBOUTL($$FMADD^XLFDT(IBDT,365)) D ^DIR
G:'Y SLDRQ S IBEDT=+Y+.999999,IBBDT=IBDT
SLDRQ Q $D(DIRUT)!($D(DUOUT))
;
PTTRAN(IBFILE,IBARRAY,IBXREF) ; builds a list of patient transactions by date
; assumes DFN, IBBDT, IBEDT
; input IBARRAY - where to store info
; IBXREF - which date x-ref to use
; output 0,6 node of file IBFILE in array specified
;
N IBIEN,IBDT,IBNODE
K @IBARRAY
S IBDT=IBBDT-.999999
F S IBDT=$O(^IBAT(IBFILE,IBXREF,DFN,IBDT)) Q:IBDT<1!(IBDT>IBEDT) D
. S IBIEN=0
. F S IBIEN=$O(^IBAT(IBFILE,IBXREF,DFN,IBDT,IBIEN)) Q:IBIEN<1 D
.. F IBNODE=0,6 S @IBARRAY@(IBDT,IBIEN,IBNODE)=$G(^IBAT(IBFILE,IBIEN,IBNODE))
Q
LMOPT ; -- called to do standard listmanager option calling
D FULL^VALM1
S VALMBCK="R"
Q
;
SETVALM(LINE,TEXT,IEN,ON,OFF) ; -- sets up listmanager lines
S LINE=LINE+1
D SET^VALM10(LINE,TEXT,LINE)
S:$G(IEN) @VALMAR@("INDEX",LINE,IEN)=""
D:$G(ON)]""!($G(OFF)]"") CNTRL^VALM10(LINE,1,$L(TEXT),$G(ON),$G(OFF))
W:'(LINE#5) "."
Q LINE
;
VISN(STATION) ; -- looks up ien & name of VISN from ien of station
N IBAT
D PARENT^XUAF4("IBAT","`"_STATION,"VISN")
S IBAT=0,IBAT=$O(IBAT("P",IBAT))
Q $S(IBAT:IBAT_"^"_$P(IBAT("P",IBAT),"^"),1:"")
;
ONEFAC() ; returns one facility only, no visns allowed
N DIC,DTOUT,DUOUT,X,Y
S DIC="^DIC(4,",DIC(0)="AEMNQ"
S DIC("S")="I $$SCR^IBATUTL(Y),$$INST^IBATUTL(Y)'[""VISN"""
D ^DIC
Q Y
FAC() ; -- facility/visn or all selection
N DIC,X,Y,DTOUT,DUOUT K IBFAC
S DIC="^DIC(4,",DIC(0)="EQMNZ"
S DIC("S")="I $$SCR^IBATUTL(Y)"
REDO W !,"Select FACILITY/VISN: ALL// " R X:DTIME Q:(X["^")!'$T 1
I X="?" W !,"Select a Facility (Name or Number), VISN (VISN XX), or press RETURN for ALL" G REDO
I X=""!($$UP^XLFSTR(X)="ALL") Q 0
D ^DIC G:Y<1 REDO D SET(Y)
S DIC("A")="Select another FACILITY/VISN: ",DIC(0)="AEQMNZ"
F D ^DIC Q:X=""!(Y<1) D SET(Y)
Q 0
SET(Y) I Y'["VISN" N IBVISN D PARENT^XUAF4("IBVISN","`"_+Y,"VISN") D
. S IBVISN=0,IBVISN=$O(IBVISN("P",IBVISN))
. S IBFAC(IBVISN,"C",+Y)=$$INST(+Y)
E S IBFAC(+Y)="" D CHILDREN^XUAF4("IBFAC(+Y)","`"_+Y,"VISN")
Q
SCR(X) ; screens invalid institution file entries
N IBVISN
;Q:$P(X,".",2) 0
D PARENT^XUAF4("IBVISN","`"_X,"VISN")
S IBVISN=0,IBVISN=$O(IBVISN("P",IBVISN)) I IBVISN Q 1
D CHILDREN^XUAF4("IBVISN","`"_X,"VISN")
S IBVISN=0,IBVISN=$O(IBVISN("C",IBVISN)) I IBVISN Q 1
Q 0
PPF(DFN) ; returns patient's enrolled/preferred facility
N IBPPF
; first find current enrolment
S IBPPF=+$$PREF^DGENPTA(DFN) ; dbia #2919
; now if they are already tp update if necessary
I $D(^IBAT(351.6,DFN)),$P(^(DFN,0),"^",3)'=IBPPF D UPPPF^IBATFILE(DFN,IBPPF)
; now if they have an over ride facility use that
Q $S($P($G(^IBAT(351.6,DFN,0)),"^",10):$P(^(0),"^",10),IBPPF=$$SITE:0,1:IBPPF)
TPP(DFN) ; returns dfn and files patient if a valid tp patient
N IBSITE,IBPPF
S IBSITE=$$SITE
S IBPPF=$$PPF(DFN)
I IBPPF,IBSITE'=IBPPF S DFN=+$$PAT^IBATFILE(DFN,IBPPF)
I DFN,$P($G(^IBAT(351.6,DFN,0)),"^",4) Q DFN
Q 0
SITE() ; returns ien of current va site (this way I have only one outside call
Q +$$SITE^VASITE
;
INST(DA) ; returns institution file info
; This will return the station name ^ station number ^ station type
; DA - The pointer value into file 4.
I '$D(^DIC(4,DA,0)) Q 0
Q $$NNT^XUAF4(DA)
IPT(X) ; returns institution file pointer from name
Q $$LKUP^XUAF4(X)
PROC(X,IBDATE) ; -- returns CPT and descriptive name for cpts
S X=$$CPT^ICPTCOD(X,$G(IBDATE))
Q $P(X,"^",2,3)
COPAY(DFN,IBFROM,IBBDT,IBEDT) ; -- returns copay amount if any
; dfn=patient's dfn, from=what event the bill is from
; ibbdt & ibedt are date ranges (n/a for rx)
N IBAMT,Y,Y1,IBDA,IBX S IBAMT=0
I IBFROM["PSRX(" D Q IBAMT
. I $P(IBFROM,";",3)>0 D Q
.. ; refills
.. S IBFROM=$$SUBFILE^IBRXUTL(+IBFROM,$P(IBFROM,";",3),52,9) I 'IBFROM Q
.. S IBAMT=$P($G(^IB(IBFROM,0)),"^",7)
. E D Q
.. ; initial fill
.. S IBFROM=$$FILE^IBRXUTL(+IBFROM,106) I 'IBFROM Q
.. S IBAMT=$P($G(^IB(IBFROM,0)),"^",7)
; now on to scheduling and admissions
S Y="" F S Y=$O(^IB("AFDT",DFN,Y)) Q:'Y I -Y'>IBEDT S Y1=0 F S Y1=$O(^IB("AFDT",DFN,Y,Y1)) Q:'Y1 D
. S IBDA=0 F S IBDA=$O(^IB("AF",Y1,IBDA)) Q:'IBDA D
.. Q:'$D(^IB(IBDA,0)) S IBX=^(0)
.. Q:$P(IBX,"^",8)["ADMISSION"
.. ;
.. ; quit if not correct type (inpatient vs outpatient)
.. Q:$S(IBFROM["SCE("&($P($P(IBX,"^",4),":")'=409.68):1,IBFROM["DGPM("&($P($P(IBX,"^",4),":")=409.68):1,1:0)
.. ;
.. I $P(IBX,"^",15)<IBBDT!($P(IBX,"^",14)>IBEDT) Q
.. S IBAMT=IBAMT+$P(IBX,"^",7)
Q IBAMT
FINDT(X) ; -- looks up transactions for source in X
; returns ien of 351.61 if not cancelled
Q:$G(X)="" 0
N Y,Z S (Y,Z)=0
F S Y=$O(^IBAT(351.61,"AD",X,Y)) Q:Y<1!(Z) D
. I $G(^IBAT(351.61,Y,0)),$P(^(0),"^",5)'="X" S Z=Y
Q Z
;
PIN(P660,P6611) ; return Prosthetics Item Description (#661.1,.02)
; input: P660 - pointer to Patient Item (#660) or P6611 - pointer to HCPCS (#661.1)
; return: pointer to HCPCS (#661.1) ^ Short Description (#661.1,.01) ^ HCPCS (#661.1,.01)
N IBX,IBY S IBY=""
I +$G(P660) S P6611=+$P($G(^RMPR(660,+P660,1)),U,4)
I +$G(P6611) S IBX=$G(^RMPR(661.1,+P6611,0)) I IBX'="" S IBY=P6611_U_$P(IBX,U,2)_U_$P(IBX,U,1)
Q IBY
;
EX(FILE,FIELD,VALUE) ; -- return external value
N Y,C S Y=$G(VALUE)
I +$G(FILE),+$G(FIELD),Y'="" S C=$P(^DD(FILE,FIELD,0),"^",2) D Y^DIQ
Q Y
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBATUTL 6766 printed Sep 02, 2024@18:53:15 Page 2
IBATUTL ;LL/ELZ - TRANSFER PRICING UTILITES ; 3-SEP-1998
+1 ;;2.0;INTEGRATED BILLING;**115,266,347,389**;21-MAR-94;Build 6
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
SL() ; -- called to select a patient or enrolled facility
+1 NEW X,Y,DTOUT,DUOUT,DIRUT,DIROUT,DIR
+2 SET DIR(0)="350.9,10.01"
SET DIR("A")="Select Patient or Enrolled Facility"
+3 DO ^DIR
+4 QUIT Y
SLPT() ; -- called to select a patient, returns 0 or patient dfn
+1 NEW X,Y,DIC,DTOUT,DUOUT
+2 SET DIC="^IBAT(351.6,"
SET DIC(0)="AEMQ"
DO ^DIC
+3 QUIT $SELECT(+Y>0:+Y,1:0)
+4 ;
SLDR(Q) ; -- called to select a date range
+1 ; defaults are from=T-365, to=TODAY
+2 ; output IBBDT, IBEDT, quit returns 0 if not valid
+3 ;
+4 NEW DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y,IBDT
+5 SET DIR(0)="DA^:NOW:EX"
SET DIR("A")="Select FROM DATE: "
+6 if $DATA(Q)
SET DIR("?")=Q
+7 DO ^DIR
if 'Y
GOTO SLDRQ
SET IBDT=+Y
+8 SET DIR(0)="DA^"_+Y_":NOW:EX"
SET DIR("A")=" TO: "
+9 DO ^DIR
+10 if Y
SET IBEDT=+Y+.999999
SET IBBDT=IBDT
GOTO SLDRQ
SLDR1Y() ; -- called to select a date range w/1y past default
+1 ; defaults are from=T-365, to=TODAY
+2 ; output IBBDT, IBEDT, quit returns 0 if not valid
+3 ;
+4 NEW DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y,IBDT
+5 SET DIR(0)="DA^:NOW:EX"
SET DIR("A")="Select FROM DATE: "
+6 SET DIR("B")=$$DAT2^IBOUTL($$FMADD^XLFDT(DT,-365))
DO ^DIR
+7 if 'Y
GOTO SLDRQ
SET IBDT=+Y
+8 SET DIR(0)="DA^"_+Y_":NOW:EX"
SET DIR("A")=" to: "
+9 SET DIR("B")=$$DAT2^IBOUTL($$FMADD^XLFDT(IBDT,365))
DO ^DIR
+10 if 'Y
GOTO SLDRQ
SET IBEDT=+Y+.999999
SET IBBDT=IBDT
SLDRQ QUIT $DATA(DIRUT)!($DATA(DUOUT))
+1 ;
PTTRAN(IBFILE,IBARRAY,IBXREF) ; builds a list of patient transactions by date
+1 ; assumes DFN, IBBDT, IBEDT
+2 ; input IBARRAY - where to store info
+3 ; IBXREF - which date x-ref to use
+4 ; output 0,6 node of file IBFILE in array specified
+5 ;
+6 NEW IBIEN,IBDT,IBNODE
+7 KILL @IBARRAY
+8 SET IBDT=IBBDT-.999999
+9 FOR
SET IBDT=$ORDER(^IBAT(IBFILE,IBXREF,DFN,IBDT))
if IBDT<1!(IBDT>IBEDT)
QUIT
Begin DoDot:1
+10 SET IBIEN=0
+11 FOR
SET IBIEN=$ORDER(^IBAT(IBFILE,IBXREF,DFN,IBDT,IBIEN))
if IBIEN<1
QUIT
Begin DoDot:2
+12 FOR IBNODE=0,6
SET @IBARRAY@(IBDT,IBIEN,IBNODE)=$GET(^IBAT(IBFILE,IBIEN,IBNODE))
End DoDot:2
End DoDot:1
+13 QUIT
LMOPT ; -- called to do standard listmanager option calling
+1 DO FULL^VALM1
+2 SET VALMBCK="R"
+3 QUIT
+4 ;
SETVALM(LINE,TEXT,IEN,ON,OFF) ; -- sets up listmanager lines
+1 SET LINE=LINE+1
+2 DO SET^VALM10(LINE,TEXT,LINE)
+3 if $GET(IEN)
SET @VALMAR@("INDEX",LINE,IEN)=""
+4 if $GET(ON)]""!($GET(OFF)]"")
DO CNTRL^VALM10(LINE,1,$LENGTH(TEXT),$GET(ON),$GET(OFF))
+5 if '(LINE#5)
WRITE "."
+6 QUIT LINE
+7 ;
VISN(STATION) ; -- looks up ien & name of VISN from ien of station
+1 NEW IBAT
+2 DO PARENT^XUAF4("IBAT","`"_STATION,"VISN")
+3 SET IBAT=0
SET IBAT=$ORDER(IBAT("P",IBAT))
+4 QUIT $SELECT(IBAT:IBAT_"^"_$PIECE(IBAT("P",IBAT),"^"),1:"")
+5 ;
ONEFAC() ; returns one facility only, no visns allowed
+1 NEW DIC,DTOUT,DUOUT,X,Y
+2 SET DIC="^DIC(4,"
SET DIC(0)="AEMNQ"
+3 SET DIC("S")="I $$SCR^IBATUTL(Y),$$INST^IBATUTL(Y)'[""VISN"""
+4 DO ^DIC
+5 QUIT Y
FAC() ; -- facility/visn or all selection
+1 NEW DIC,X,Y,DTOUT,DUOUT
KILL IBFAC
+2 SET DIC="^DIC(4,"
SET DIC(0)="EQMNZ"
+3 SET DIC("S")="I $$SCR^IBATUTL(Y)"
REDO WRITE !,"Select FACILITY/VISN: ALL// "
READ X:DTIME
if (X["^")!'$TEST
QUIT 1
+1 IF X="?"
WRITE !,"Select a Facility (Name or Number), VISN (VISN XX), or press RETURN for ALL"
GOTO REDO
+2 IF X=""!($$UP^XLFSTR(X)="ALL")
QUIT 0
+3 DO ^DIC
if Y<1
GOTO REDO
DO SET(Y)
+4 SET DIC("A")="Select another FACILITY/VISN: "
SET DIC(0)="AEQMNZ"
+5 FOR
DO ^DIC
if X=""!(Y<1)
QUIT
DO SET(Y)
+6 QUIT 0
SET(Y) IF Y'["VISN"
NEW IBVISN
DO PARENT^XUAF4("IBVISN","`"_+Y,"VISN")
Begin DoDot:1
+1 SET IBVISN=0
SET IBVISN=$ORDER(IBVISN("P",IBVISN))
+2 SET IBFAC(IBVISN,"C",+Y)=$$INST(+Y)
End DoDot:1
+3 IF '$TEST
SET IBFAC(+Y)=""
DO CHILDREN^XUAF4("IBFAC(+Y)","`"_+Y,"VISN")
+4 QUIT
SCR(X) ; screens invalid institution file entries
+1 NEW IBVISN
+2 ;Q:$P(X,".",2) 0
+3 DO PARENT^XUAF4("IBVISN","`"_X,"VISN")
+4 SET IBVISN=0
SET IBVISN=$ORDER(IBVISN("P",IBVISN))
IF IBVISN
QUIT 1
+5 DO CHILDREN^XUAF4("IBVISN","`"_X,"VISN")
+6 SET IBVISN=0
SET IBVISN=$ORDER(IBVISN("C",IBVISN))
IF IBVISN
QUIT 1
+7 QUIT 0
PPF(DFN) ; returns patient's enrolled/preferred facility
+1 NEW IBPPF
+2 ; first find current enrolment
+3 ; dbia #2919
SET IBPPF=+$$PREF^DGENPTA(DFN)
+4 ; now if they are already tp update if necessary
+5 IF $DATA(^IBAT(351.6,DFN))
IF $PIECE(^(DFN,0),"^",3)'=IBPPF
DO UPPPF^IBATFILE(DFN,IBPPF)
+6 ; now if they have an over ride facility use that
+7 QUIT $SELECT($PIECE($GET(^IBAT(351.6,DFN,0)),"^",10):$PIECE(^(0),"^",10),IBPPF=$$SITE:0,1:IBPPF)
TPP(DFN) ; returns dfn and files patient if a valid tp patient
+1 NEW IBSITE,IBPPF
+2 SET IBSITE=$$SITE
+3 SET IBPPF=$$PPF(DFN)
+4 IF IBPPF
IF IBSITE'=IBPPF
SET DFN=+$$PAT^IBATFILE(DFN,IBPPF)
+5 IF DFN
IF $PIECE($GET(^IBAT(351.6,DFN,0)),"^",4)
QUIT DFN
+6 QUIT 0
SITE() ; returns ien of current va site (this way I have only one outside call
+1 QUIT +$$SITE^VASITE
+2 ;
INST(DA) ; returns institution file info
+1 ; This will return the station name ^ station number ^ station type
+2 ; DA - The pointer value into file 4.
+3 IF '$DATA(^DIC(4,DA,0))
QUIT 0
+4 QUIT $$NNT^XUAF4(DA)
IPT(X) ; returns institution file pointer from name
+1 QUIT $$LKUP^XUAF4(X)
PROC(X,IBDATE) ; -- returns CPT and descriptive name for cpts
+1 SET X=$$CPT^ICPTCOD(X,$GET(IBDATE))
+2 QUIT $PIECE(X,"^",2,3)
COPAY(DFN,IBFROM,IBBDT,IBEDT) ; -- returns copay amount if any
+1 ; dfn=patient's dfn, from=what event the bill is from
+2 ; ibbdt & ibedt are date ranges (n/a for rx)
+3 NEW IBAMT,Y,Y1,IBDA,IBX
SET IBAMT=0
+4 IF IBFROM["PSRX("
Begin DoDot:1
+5 IF $PIECE(IBFROM,";",3)>0
Begin DoDot:2
+6 ; refills
+7 SET IBFROM=$$SUBFILE^IBRXUTL(+IBFROM,$PIECE(IBFROM,";",3),52,9)
IF 'IBFROM
QUIT
+8 SET IBAMT=$PIECE($GET(^IB(IBFROM,0)),"^",7)
End DoDot:2
QUIT
+9 IF '$TEST
Begin DoDot:2
+10 ; initial fill
+11 SET IBFROM=$$FILE^IBRXUTL(+IBFROM,106)
IF 'IBFROM
QUIT
+12 SET IBAMT=$PIECE($GET(^IB(IBFROM,0)),"^",7)
End DoDot:2
QUIT
End DoDot:1
QUIT IBAMT
+13 ; now on to scheduling and admissions
+14 SET Y=""
FOR
SET Y=$ORDER(^IB("AFDT",DFN,Y))
if 'Y
QUIT
IF -Y'>IBEDT
SET Y1=0
FOR
SET Y1=$ORDER(^IB("AFDT",DFN,Y,Y1))
if 'Y1
QUIT
Begin DoDot:1
+15 SET IBDA=0
FOR
SET IBDA=$ORDER(^IB("AF",Y1,IBDA))
if 'IBDA
QUIT
Begin DoDot:2
+16 if '$DATA(^IB(IBDA,0))
QUIT
SET IBX=^(0)
+17 if $PIECE(IBX,"^",8)["ADMISSION"
QUIT
+18 ;
+19 ; quit if not correct type (inpatient vs outpatient)
+20 if $SELECT(IBFROM["SCE("&($PIECE($PIECE(IBX,"^",4),"
QUIT
+21 ;
+22 IF $PIECE(IBX,"^",15)<IBBDT!($PIECE(IBX,"^",14)>IBEDT)
QUIT
+23 SET IBAMT=IBAMT+$PIECE(IBX,"^",7)
End DoDot:2
End DoDot:1
+24 QUIT IBAMT
FINDT(X) ; -- looks up transactions for source in X
+1 ; returns ien of 351.61 if not cancelled
+2 if $GET(X)=""
QUIT 0
+3 NEW Y,Z
SET (Y,Z)=0
+4 FOR
SET Y=$ORDER(^IBAT(351.61,"AD",X,Y))
if Y<1!(Z)
QUIT
Begin DoDot:1
+5 IF $GET(^IBAT(351.61,Y,0))
IF $PIECE(^(0),"^",5)'="X"
SET Z=Y
End DoDot:1
+6 QUIT Z
+7 ;
PIN(P660,P6611) ; return Prosthetics Item Description (#661.1,.02)
+1 ; input: P660 - pointer to Patient Item (#660) or P6611 - pointer to HCPCS (#661.1)
+2 ; return: pointer to HCPCS (#661.1) ^ Short Description (#661.1,.01) ^ HCPCS (#661.1,.01)
+3 NEW IBX,IBY
SET IBY=""
+4 IF +$GET(P660)
SET P6611=+$PIECE($GET(^RMPR(660,+P660,1)),U,4)
+5 IF +$GET(P6611)
SET IBX=$GET(^RMPR(661.1,+P6611,0))
IF IBX'=""
SET IBY=P6611_U_$PIECE(IBX,U,2)_U_$PIECE(IBX,U,1)
+6 QUIT IBY
+7 ;
EX(FILE,FIELD,VALUE) ; -- return external value
+1 NEW Y,C
SET Y=$GET(VALUE)
+2 IF +$GET(FILE)
IF +$GET(FIELD)
IF Y'=""
SET C=$PIECE(^DD(FILE,FIELD,0),"^",2)
DO Y^DIQ
+3 QUIT Y
+4 ;
