- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATUTL.m
r613 r623 1 IBATUTL ;LL/ELZ - TRANSFER PRICING UTILITES ; 3-SEP-1998 2 ;;2.0;INTEGRATED BILLING;**115,266,347,389**;21-MAR-94;Build 6 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 PIN(P660,P6611) ; return Prosthetics Item Description (#661.1,.02) 164 ; input: P660 - pointer to Patient Item (#660) or P6611 - pointer to HCPCS (#661.1) 165 ; return: pointer to HCPCS (#661.1) ^ Short Description (#661.1,.01) ^ HCPCS (#661.1,.01) 166 N IBX,IBY S IBY="" 167 I +$G(P660) S P6611=+$P($G(^RMPR(660,+P660,1)),U,4) 168 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) 169 Q IBY 170 ; 171 EX(FILE,FIELD,VALUE) ; -- return external value 172 N Y,C S Y=$G(VALUE) 173 I +$G(FILE),+$G(FIELD),Y'="" S C=$P(^DD(FILE,FIELD,0),"^",2) D Y^DIQ 174 Q Y 175 ; 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 ;
Note:
See TracChangeset
for help on using the changeset viewer.
