| 1 | IBATUTL ;LL/ELZ - TRANSFER PRICING UTILITES ; 3-SEP-1998
|
|---|
| 2 | ;;2.0;INTEGRATED BILLING;**115,266,347**;21-MAR-94;Build 24
|
|---|
| 3 | ;;Per VHA Directive 2004-038, this routine should not be modified.
|
|---|
| 4 | ;
|
|---|
| 5 | SL() ; -- called to select a patient or enrolled facility
|
|---|
| 6 | N X,Y,DTOUT,DUOUT,DIRUT,DIROUT,DIR
|
|---|
| 7 | S DIR(0)="350.9,10.01",DIR("A")="Select Patient or Enrolled Facility"
|
|---|
| 8 | D ^DIR
|
|---|
| 9 | Q Y
|
|---|
| 10 | SLPT() ; -- called to select a patient, returns 0 or patient dfn
|
|---|
| 11 | N X,Y,DIC,DTOUT,DUOUT
|
|---|
| 12 | S DIC="^IBAT(351.6,",DIC(0)="AEMQ" D ^DIC
|
|---|
| 13 | Q $S(+Y>0:+Y,1:0)
|
|---|
| 14 | ;
|
|---|
| 15 | SLDR(Q) ; -- called to select a date range
|
|---|
| 16 | ; defaults are from=T-365, to=TODAY
|
|---|
| 17 | ; output IBBDT, IBEDT, quit returns 0 if not valid
|
|---|
| 18 | ;
|
|---|
| 19 | N DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y,IBDT
|
|---|
| 20 | S DIR(0)="DA^:NOW:EX",DIR("A")="Select FROM DATE: "
|
|---|
| 21 | S:$D(Q) DIR("?")=Q
|
|---|
| 22 | D ^DIR G:'Y SLDRQ S IBDT=+Y
|
|---|
| 23 | S DIR(0)="DA^"_+Y_":NOW:EX",DIR("A")=" TO: "
|
|---|
| 24 | D ^DIR
|
|---|
| 25 | S:Y IBEDT=+Y+.999999,IBBDT=IBDT G SLDRQ
|
|---|
| 26 | SLDR1Y() ; -- called to select a date range w/1y past default
|
|---|
| 27 | ; defaults are from=T-365, to=TODAY
|
|---|
| 28 | ; output IBBDT, IBEDT, quit returns 0 if not valid
|
|---|
| 29 | ;
|
|---|
| 30 | N DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y,IBDT
|
|---|
| 31 | S DIR(0)="DA^:NOW:EX",DIR("A")="Select FROM DATE: "
|
|---|
| 32 | S DIR("B")=$$DAT2^IBOUTL($$FMADD^XLFDT(DT,-365)) D ^DIR
|
|---|
| 33 | G:'Y SLDRQ S IBDT=+Y
|
|---|
| 34 | S DIR(0)="DA^"_+Y_":NOW:EX",DIR("A")=" to: "
|
|---|
| 35 | S DIR("B")=$$DAT2^IBOUTL($$FMADD^XLFDT(IBDT,365)) D ^DIR
|
|---|
| 36 | G:'Y SLDRQ S IBEDT=+Y+.999999,IBBDT=IBDT
|
|---|
| 37 | SLDRQ Q $D(DIRUT)!($D(DUOUT))
|
|---|
| 38 | ;
|
|---|
| 39 | PTTRAN(IBFILE,IBARRAY,IBXREF) ; builds a list of patient transactions by date
|
|---|
| 40 | ; assumes DFN, IBBDT, IBEDT
|
|---|
| 41 | ; input IBARRAY - where to store info
|
|---|
| 42 | ; IBXREF - which date x-ref to use
|
|---|
| 43 | ; output 0,6 node of file IBFILE in array specified
|
|---|
| 44 | ;
|
|---|
| 45 | N IBIEN,IBDT,IBNODE
|
|---|
| 46 | K @IBARRAY
|
|---|
| 47 | S IBDT=IBBDT-.999999
|
|---|
| 48 | F S IBDT=$O(^IBAT(IBFILE,IBXREF,DFN,IBDT)) Q:IBDT<1!(IBDT>IBEDT) D
|
|---|
| 49 | . S IBIEN=0
|
|---|
| 50 | . F S IBIEN=$O(^IBAT(IBFILE,IBXREF,DFN,IBDT,IBIEN)) Q:IBIEN<1 D
|
|---|
| 51 | .. F IBNODE=0,6 S @IBARRAY@(IBDT,IBIEN,IBNODE)=$G(^IBAT(IBFILE,IBIEN,IBNODE))
|
|---|
| 52 | Q
|
|---|
| 53 | LMOPT ; -- called to do standard listmanager option calling
|
|---|
| 54 | D FULL^VALM1
|
|---|
| 55 | S VALMBCK="R"
|
|---|
| 56 | Q
|
|---|
| 57 | ;
|
|---|
| 58 | SETVALM(LINE,TEXT,IEN,ON,OFF) ; -- sets up listmanager lines
|
|---|
| 59 | S LINE=LINE+1
|
|---|
| 60 | D SET^VALM10(LINE,TEXT,LINE)
|
|---|
| 61 | S:$G(IEN) @VALMAR@("INDEX",LINE,IEN)=""
|
|---|
| 62 | D:$G(ON)]""!($G(OFF)]"") CNTRL^VALM10(LINE,1,$L(TEXT),$G(ON),$G(OFF))
|
|---|
| 63 | W:'(LINE#5) "."
|
|---|
| 64 | Q LINE
|
|---|
| 65 | ;
|
|---|
| 66 | VISN(STATION) ; -- looks up ien & name of VISN from ien of station
|
|---|
| 67 | N IBAT
|
|---|
| 68 | D PARENT^XUAF4("IBAT","`"_STATION,"VISN")
|
|---|
| 69 | S IBAT=0,IBAT=$O(IBAT("P",IBAT))
|
|---|
| 70 | Q $S(IBAT:IBAT_"^"_$P(IBAT("P",IBAT),"^"),1:"")
|
|---|
| 71 | ;
|
|---|
| 72 | ONEFAC() ; returns one facility only, no visns allowed
|
|---|
| 73 | N DIC,DTOUT,DUOUT,X,Y
|
|---|
| 74 | S DIC="^DIC(4,",DIC(0)="AEMNQ"
|
|---|
| 75 | S DIC("S")="I $$SCR^IBATUTL(Y),$$INST^IBATUTL(Y)'[""VISN"""
|
|---|
| 76 | D ^DIC
|
|---|
| 77 | Q Y
|
|---|
| 78 | FAC() ; -- facility/visn or all selection
|
|---|
| 79 | N DIC,X,Y,DTOUT,DUOUT K IBFAC
|
|---|
| 80 | S DIC="^DIC(4,",DIC(0)="EQMNZ"
|
|---|
| 81 | S DIC("S")="I $$SCR^IBATUTL(Y)"
|
|---|
| 82 | REDO W !,"Select FACILITY/VISN: ALL// " R X:DTIME Q:(X["^")!'$T 1
|
|---|
| 83 | I X="?" W !,"Select a Facility (Name or Number), VISN (VISN XX), or press RETURN for ALL" G REDO
|
|---|
| 84 | I X=""!($$UP^XLFSTR(X)="ALL") Q 0
|
|---|
| 85 | D ^DIC G:Y<1 REDO D SET(Y)
|
|---|
| 86 | S DIC("A")="Select another FACILITY/VISN: ",DIC(0)="AEQMNZ"
|
|---|
| 87 | F D ^DIC Q:X=""!(Y<1) D SET(Y)
|
|---|
| 88 | Q 0
|
|---|
| 89 | SET(Y) I Y'["VISN" N IBVISN D PARENT^XUAF4("IBVISN","`"_+Y,"VISN") D
|
|---|
| 90 | . S IBVISN=0,IBVISN=$O(IBVISN("P",IBVISN))
|
|---|
| 91 | . S IBFAC(IBVISN,"C",+Y)=$$INST(+Y)
|
|---|
| 92 | E S IBFAC(+Y)="" D CHILDREN^XUAF4("IBFAC(+Y)","`"_+Y,"VISN")
|
|---|
| 93 | Q
|
|---|
| 94 | SCR(X) ; screens invalid institution file entries
|
|---|
| 95 | N IBVISN
|
|---|
| 96 | ;Q:$P(X,".",2) 0
|
|---|
| 97 | D PARENT^XUAF4("IBVISN","`"_X,"VISN")
|
|---|
| 98 | S IBVISN=0,IBVISN=$O(IBVISN("P",IBVISN)) I IBVISN Q 1
|
|---|
| 99 | D CHILDREN^XUAF4("IBVISN","`"_X,"VISN")
|
|---|
| 100 | S IBVISN=0,IBVISN=$O(IBVISN("C",IBVISN)) I IBVISN Q 1
|
|---|
| 101 | Q 0
|
|---|
| 102 | PPF(DFN) ; returns patient's enrolled/preferred facility
|
|---|
| 103 | N IBPPF
|
|---|
| 104 | ; first find current enrolment
|
|---|
| 105 | S IBPPF=+$$PREF^DGENPTA(DFN) ; dbia #2919
|
|---|
| 106 | ; now if they are already tp update if necessary
|
|---|
| 107 | I $D(^IBAT(351.6,DFN)),$P(^(DFN,0),"^",3)'=IBPPF D UPPPF^IBATFILE(DFN,IBPPF)
|
|---|
| 108 | ; now if they have an over ride facility use that
|
|---|
| 109 | Q $S($P($G(^IBAT(351.6,DFN,0)),"^",10):$P(^(0),"^",10),IBPPF=$$SITE:0,1:IBPPF)
|
|---|
| 110 | TPP(DFN) ; returns dfn and files patient if a valid tp patient
|
|---|
| 111 | N IBSITE,IBPPF
|
|---|
| 112 | S IBSITE=$$SITE
|
|---|
| 113 | S IBPPF=$$PPF(DFN)
|
|---|
| 114 | I IBPPF,IBSITE'=IBPPF S DFN=+$$PAT^IBATFILE(DFN,IBPPF)
|
|---|
| 115 | I DFN,$P($G(^IBAT(351.6,DFN,0)),"^",4) Q DFN
|
|---|
| 116 | Q 0
|
|---|
| 117 | SITE() ; returns ien of current va site (this way I have only one outside call
|
|---|
| 118 | Q +$$SITE^VASITE
|
|---|
| 119 | ;
|
|---|
| 120 | INST(DA) ; returns institution file info
|
|---|
| 121 | ; This will return the station name ^ station number ^ station type
|
|---|
| 122 | ; DA - The pointer value into file 4.
|
|---|
| 123 | I '$D(^DIC(4,DA,0)) Q 0
|
|---|
| 124 | Q $$NNT^XUAF4(DA)
|
|---|
| 125 | IPT(X) ; returns institution file pointer from name
|
|---|
| 126 | Q $$LKUP^XUAF4(X)
|
|---|
| 127 | PROC(X,IBDATE) ; -- returns CPT and descriptive name for cpts
|
|---|
| 128 | S X=$$CPT^ICPTCOD(X,$G(IBDATE))
|
|---|
| 129 | Q $P(X,"^",2,3)
|
|---|
| 130 | COPAY(DFN,IBFROM,IBBDT,IBEDT) ; -- returns copay amount if any
|
|---|
| 131 | ; dfn=patient's dfn, from=what event the bill is from
|
|---|
| 132 | ; ibbdt & ibedt are date ranges (n/a for rx)
|
|---|
| 133 | N IBAMT,Y,Y1,IBDA,IBX S IBAMT=0
|
|---|
| 134 | I IBFROM["PSRX(" D Q IBAMT
|
|---|
| 135 | . I $P(IBFROM,";",3)>0 D Q
|
|---|
| 136 | .. ; refills
|
|---|
| 137 | .. S IBFROM=$$SUBFILE^IBRXUTL(+IBFROM,$P(IBFROM,";",3),52,9) I 'IBFROM Q
|
|---|
| 138 | .. S IBAMT=$P($G(^IB(IBFROM,0)),"^",7)
|
|---|
| 139 | . E D Q
|
|---|
| 140 | .. ; initial fill
|
|---|
| 141 | .. S IBFROM=$$FILE^IBRXUTL(+IBFROM,106) I 'IBFROM Q
|
|---|
| 142 | .. S IBAMT=$P($G(^IB(IBFROM,0)),"^",7)
|
|---|
| 143 | ; now on to scheduling and admissions
|
|---|
| 144 | 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
|
|---|
| 145 | . S IBDA=0 F S IBDA=$O(^IB("AF",Y1,IBDA)) Q:'IBDA D
|
|---|
| 146 | .. Q:'$D(^IB(IBDA,0)) S IBX=^(0)
|
|---|
| 147 | .. Q:$P(IBX,"^",8)["ADMISSION"
|
|---|
| 148 | .. ;
|
|---|
| 149 | .. ; quit if not correct type (inpatient vs outpatient)
|
|---|
| 150 | .. Q:$S(IBFROM["SCE("&($P($P(IBX,"^",4),":")'=409.68):1,IBFROM["DGPM("&($P($P(IBX,"^",4),":")=409.68):1,1:0)
|
|---|
| 151 | .. ;
|
|---|
| 152 | .. I $P(IBX,"^",15)<IBBDT!($P(IBX,"^",14)>IBEDT) Q
|
|---|
| 153 | .. S IBAMT=IBAMT+$P(IBX,"^",7)
|
|---|
| 154 | Q IBAMT
|
|---|
| 155 | FINDT(X) ; -- looks up transactions for source in X
|
|---|
| 156 | ; returns ien of 351.61 if not cancelled
|
|---|
| 157 | Q:$G(X)="" 0
|
|---|
| 158 | N Y,Z S (Y,Z)=0
|
|---|
| 159 | F S Y=$O(^IBAT(351.61,"AD",X,Y)) Q:Y<1!(Z) D
|
|---|
| 160 | . I $G(^IBAT(351.61,Y,0)),$P(^(0),"^",5)'="X" S Z=Y
|
|---|
| 161 | Q Z
|
|---|
| 162 | ;
|
|---|
| 163 | EX(FILE,FIELD,VALUE) ; -- return external value
|
|---|
| 164 | N Y,C S Y=$G(VALUE)
|
|---|
| 165 | I +$G(FILE),+$G(FIELD),Y'="" S C=$P(^DD(FILE,FIELD,0),"^",2) D Y^DIQ
|
|---|
| 166 | Q Y
|
|---|
| 167 | ;
|
|---|
