- 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/IBATFILE.m
r613 r623 1 IBATFILE 2 ;;2.0;INTEGRATED BILLING;**115,389**;21-MAR-94;Build 6 3 ;;Per VHA Directive 2004-038, this routine should not be modified.4 PAT(DA,IBFAC,IBOVER) 5 6 7 8 9 10 11 12 UPPPF(DA,PPF) 13 14 15 16 17 ADM(DFN,IBADMDT,IBPREF,IBSOURCE) 18 19 20 21 22 DIS(DA,IBDISDT,IBPTF,IBDISM) 23 24 25 26 27 28 29 30 31 32 DISC(DA) 33 34 35 36 37 38 39 40 INPT(IBIEN,IBDRG,IBDRGA,IBLOS,IBHIGH,IBOUT,IBOUTR) 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 OUT(DFN,IBEDT,IBPREF,IBSOURCE,IBPROC) 57 58 59 60 61 62 63 64 65 66 67 68 69 70 UPDATE(IBIEN,IBPROC) 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 RX(DFN,IBEDT,IBPREF,IBSOURCE,IBDRUG,IBQTY,IBCOST) 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 RMPR(DFN,IBEDT,IBPREF,IBSOURCE,IBPROS,IBCOST) 104 105 106 ; IBPROS=ien from file 661 - removed in 389 no longer valid 107 108 I '$G(DFN)!('$G(IBEDT))!('$G(IBPREF))!($G(IBSOURCE)="") Q 0109 110 111 112 S DR=".1////"_+IBEDT_";.05////"_$S($G(IBCOST):"P;4.05////"_+IBCOST_";.13////"_DT,1:"C")113 114 115 116 117 118 CANC(DA) 119 120 121 122 DEL(DA) 123 124 125 126 127 128 NEW(DFN,IBEDT,IBPREF,IBSOURCE) 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 PROC(IBIEN,IBPROC,IBPRICE) 144 145 146 147 148 149 150 151 152 153 154 155 156 DX(IBIEN,IBPTF) 157 158 159 160 161 162 163 164 165 166 INIT 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 ADDTP 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 1 IBATFILE ;LL/ELZ - TRANSFER PRICING FILLING ; 22-JAN-1999 2 ;;2.0;INTEGRATED BILLING;**115**;21-MAR-94 3 ;;Per VHA Directive 10-93-142, this routine should not be modified. 4 PAT(DA,IBFAC,IBOVER) ; files patient in transfer pricing returns dfn 5 Q:'$G(DA) 0 6 I $D(^IBAT(351.6,DA,0)) Q DA 7 N DO,DD,DIC,X,DINUM 8 S DIC="^IBAT(351.6,",DIC(0)="",X=DA,DINUM=DA 9 S DIC("DR")=".02///"_$$NOW^XLFDT_";.03////"_+$S($G(IBFAC):IBFAC,1:$$PPF^IBATUTL(DA))_";.04///1"_$S($D(IBOVER):";.1////"_+IBOVER,1:"") 10 D FILE^DICN 11 Q $S(Y>0:Y,1:0) 12 UPPPF(DA,PPF) ; updates a patient's enrolled facility 13 I '$G(DA)!('$G(PPF))!('$D(^IBAT(351.6,DA))) Q 14 N DIE,DR 15 S DIE="^IBAT(351.6,",DR=".03////"_+PPF D ^DIE 16 Q 17 ADM(DFN,IBADMDT,IBPREF,IBSOURCE) ; - files admissions 18 ; IBADMDT=admission date, IBPREF=enrolled facility 19 ; IBSOURCE=source (movement ien;DGPM( 20 I '$G(DFN)!('$G(IBADMDT))!('$G(IBPREF))!($G(IBSOURCE)="") Q 0 21 Q $$NEW(DFN,IBADMDT,IBPREF,IBSOURCE) 22 DIS(DA,IBDISDT,IBPTF,IBDISM) ; - files discharges 23 ; DA=transaction ien in 351.61, IBDISDT=discharge date 24 ; IBPTF=ptf pointer, IBDISM=discharge movement pointer 25 I '$G(DA)!('$G(IBDISDT))!('$G(IBPTF))!('$G(IBDISM)) Q 0 26 N DIE,DR 27 S DIE="^IBAT(351.61," 28 S DR=".05////C;.1////"_IBDISDT_";1.07////"_IBPTF_";1.08////"_IBDISM 29 L +^IBAT(351.61,DA):10 I '$T Q "0^Transaction Locked" 30 D ^DIE L -^IBAT(351.61,DA) 31 Q DA 32 DISC(DA) ; - deletes discharge data 33 ; DA=transaction ien in 351.61 34 N DIE,DR Q:'$G(DA) 0 35 S DIE="^IBAT(351.61," 36 S DR=".05////E;.1///@;1.08///@" 37 L +^IBAT(351.61,DA):10 I '$T Q "0^Transaction Locked" 38 D ^DIE L -^IBAT(351.61,DA) 39 Q DA 40 INPT(IBIEN,IBDRG,IBDRGA,IBLOS,IBHIGH,IBOUT,IBOUTR) ; - file remaining inpt 41 ; IBIEN=transaction ien in 351.61, IBDRG=DRG pointer 42 ; IBDRGA=DRG amount,IBLOS=inpatient LOS,IBHIGH=high trim days 43 ; IBOUT=outlier days,IBOUTR=outlier rate 44 I '$G(IBIEN)!('$G(IBLOS))!('$D(IBHIGH))!('$D(IBOUT)) Q 0 45 N DIE,X,Y,DR 46 S DIE="^IBAT(351.61,",DA=IBIEN 47 S DR="1.03////"_IBLOS_";1.04////"_IBHIGH_";1.05////"_IBOUT 48 S:$G(IBDRG) DR=DR_";1.01///"_IBDRG 49 S:$G(IBDRGA) DR=DR_";1.02////"_IBDRGA 50 S:$G(IBOUTR) DR=DR_";1.06////"_IBOUTR 51 L +^IBAT(351.61,IBIEN):10 I '$T Q "0^Transaction Locked" 52 D ^DIE,TOTAL^IBATCM(IBIEN) I $P($G(^IBAT(351.61,IBIEN,6)),"^",2) D 53 . S DR=";.05////P;.13////"_DT D ^DIE 54 L -^IBAT(351.61,IBIEN) 55 Q IBIEN 56 OUT(DFN,IBEDT,IBPREF,IBSOURCE,IBPROC) ; - files outpatient data 57 ; DFN=dfn for patient, IBEDT=event date, IBPREF=enrolled facility 58 ; IBSOURCE=source (outpatient encounter ien;SCE( 59 ; IBPROC=procedures (by ref in array) 60 I '$G(DFN)!('$G(IBEDT))!('$G(IBPREF))!($G(IBSOURCE)="") Q 0 61 N IBIEN,IBX,Y,IBPRICE 62 S IBIEN=$$NEW(DFN,IBEDT,IBPREF,IBSOURCE) I 'IBIEN Q IBIEN 63 L +^IBAT(351.61,IBIEN):10 I '$T Q "0^Transaction Locked" 64 S IBIEN=$$PROC(IBIEN,.IBPROC,.IBPRICE) ; file procedures 65 I IBIEN<1 L -^IBAT(351.61,IBIEN) Q "0^Unable to file procedures" 66 S DIE="^IBAT(351.61,",DA=IBIEN 67 S DR=".1////"_IBEDT_";.05////"_$S($G(IBPRICE):"C",1:"P;.13////"_DT) 68 D ^DIE,TOTAL^IBATCM(IBIEN) L -^IBAT(351.61,IBIEN) 69 Q IBIEN 70 UPDATE(IBIEN,IBPROC) ; -- updates procedures 71 ; IBIEN=351.61 ien, IBPROC=procedures by ref like above 72 Q:'$G(IBIEN) 0 73 N IBX,IBPRICE,DIE,DA,DR,X,Y 74 S IBIEN(0)=^IBAT(351.61,IBIEN,0),IBEDT=$P(IBIEN(0),"^",4) 75 ; if approved, cancel and create a new one 76 I $P(IBIEN(0),"^",5)="A" D Q IBIEN 77 . S IBIEN=$$CANC(IBIEN) 78 . S IBIEN=$$OUT($P(IBIEN(0),"^",2),IBEDT,$P(IBIEN(0),"^",11),$P(IBIEN(0),"^",12),.IBPROC) 79 L +^IBAT(351.61,IBIEN):10 I '$T Q "0^Transaction Locked" 80 ; first clean out procedures there 81 S IBX=0 F S IBX=$O(^IBAT(351.61,IBIEN,3,IBX)) Q:IBX<1 S DIK="^IBAT(351.61,"_IBIEN_",3,",DA(1)=IBIEN,DA=IBX D ^DIK 82 S IBIEN=$$PROC(IBIEN,.IBPROC,.IBPRICE) ; file procedures 83 I IBIEN<1 L -^IBAT(351.61,IBIEN) Q "0^Unable to file procedures" 84 S DIE="^IBAT(351.61,",DA=IBIEN 85 S DR=".1////"_IBEDT_";.05////"_$S($G(IBPRICE):"C",1:"P;.13////"_DT) 86 D ^DIE,TOTAL^IBATCM(IBIEN) L -^IBAT(351.61,IBIEN) 87 Q IBIEN 88 RX(DFN,IBEDT,IBPREF,IBSOURCE,IBDRUG,IBQTY,IBCOST) ; - files pharmacy data 89 ; DFN=dfn for patient, IBEDT=event date, IBPREF=enrolled facility 90 ; IBSOURCE=source (prescription ien;PSRX(;refill # 91 ; IBDRUG=ien from drug file 92 ; IBQTY=quantity of drug, IBCOST=drug cost 93 I '$G(DFN)!('$G(IBEDT))!('$G(IBPREF))!($G(IBSOURCE)="")!('$G(IBDRUG))!('$G(IBQTY)) Q 0 94 N IBIEN 95 S IBIEN=$$NEW(DFN,IBEDT,IBPREF,IBSOURCE) I 'IBIEN Q IBIEN 96 S DIE="^IBAT(351.61,",DA=IBIEN 97 S DR=".1////"_+IBEDT_";4.01////"_+IBDRUG_";4.02////"_+IBQTY_";.05////"_$S($G(IBCOST):"P;4.03////"_+IBCOST_";.13////"_DT,1:"C") 98 L +^IBAT(351.61,IBIEN):10 I '$T Q "0^Transaction Locked" 99 D ^DIE D:$G(IBCOST) TOTAL^IBATCM(IBIEN) 100 L -^IBAT(351.61,IBIEN) 101 Q IBIEN 102 ; 103 RMPR(DFN,IBEDT,IBPREF,IBSOURCE,IBPROS,IBCOST) ; - files prost. data 104 ; DFN=dfn for patient, IBEDT=event date, IBPREF=enrolled facility 105 ; IBSOURCE=source (prost ien;RMPR(660, 106 ; IBPROS=ien from file 661 107 ; IBCOST=item cost 108 I '$G(DFN)!('$G(IBEDT))!('$G(IBPREF))!($G(IBSOURCE)="")!('$G(IBPROS)) Q 0 109 N IBIEN 110 S IBIEN=$$NEW(DFN,IBEDT,IBPREF,IBSOURCE) I 'IBIEN Q IBIEN 111 S DIE="^IBAT(351.61,",DA=IBIEN 112 S DR=".1////"_+IBEDT_";4.04////"_+IBPROS_";.05////"_$S($G(IBCOST):"P;4.05////"_+IBCOST_";.13////"_DT,1:"C") 113 L +^IBAT(351.61,IBIEN):10 I '$T Q "0^Transaction Locked" 114 D ^DIE D:$G(IBCOST) TOTAL^IBATCM(IBIEN) 115 L -^IBAT(351.61,IBIEN) 116 Q IBIEN 117 ; 118 CANC(DA) ; - used to cancel any transaction 119 N DIE,DR,X,Y Q:'$G(DA) 120 S DIE="^IBAT(351.61,",DR=".05///X" D ^DIE 121 Q 122 DEL(DA) ; - used to delete a transaction (only valid for inpatients or rx) 123 N DIK,DR,X,Y,Z Q:'$G(DA) 124 S Z=$G(^IBAT(351.61,DA,0)) Q:'Z 125 Q:$P(Z,"^",12)["SCE(" 126 S DIK="^IBAT(351.61," D ^DIK 127 Q 128 NEW(DFN,IBEDT,IBPREF,IBSOURCE) ; - creates new transaction and returns ien 129 N IBIEN,IBSITE,DD,DO,DIC,X,Y,DINUM,DLAYGO,DIE,DA,DR 130 S IBSITE=$$SITE^IBATUTL 131 L +^IBAT(351.6,DFN):10 I '$T Q "0^Patient file Locked" 132 L +^IBAT(351.61,0):10 I '$T Q "0^Transaction File Locked" 133 S IBIEN=$P(^IBAT(351.61,0),"^",3)+1 134 F IBIEN=IBIEN:1 Q:'$D(^IBAT(351.61,"B",IBSITE_IBIEN)) 135 S DIC="^IBAT(351.61,",DIC(0)="",X=IBSITE_IBIEN,DINUM=IBIEN,DLAYGO=351.61 136 S DIC("DR")=".02////"_+DFN_";.03////"_+DT_";.04////"_+IBEDT_";.05////E;.09////"_+IBEDT_";.11////"_+IBPREF_";.12////^S X=IBSOURCE" 137 D FILE^DICN I +Y<1 L -(^IBAT(351.61,0),^IBAT(351.6,DFN)) Q "0^Unable to add new transaction" 138 S DIE="^IBAT(351.6,",DA=+DFN 139 S DR=$S(IBSOURCE["DGPM":".05",IBSOURCE["SCE":".06",IBSOURCE["RMPR":".11",1:".07")_"////"_+IBEDT 140 I $P(^IBAT(351.6,DFN,0),"^",+(DR*100))<IBEDT D ^DIE 141 L -(^IBAT(351.61,0),^IBAT(351.6,DFN)) 142 Q IBIEN 143 PROC(IBIEN,IBPROC,IBPRICE) ; files procedures 144 N X,Y 145 S Y=1,IBX=0 F S IBX=$O(IBPROC(IBX)) Q:IBX=""!(+Y<1) D 146 . N DIC,X,DA,DD,DO 147 . S DIC="^IBAT(351.61,"_IBIEN_",3,",DIC(0)="L" 148 . S X=IBX,DA(1)=IBIEN 149 . ;S DIC("P")=$P(^DD(351.61,3,0),"^",2) ; no longer required with fm22 150 . S DIC("DR")=".02////"_$P(IBPROC(IBX),"^") 151 . I $P(IBPROC(IBX),"^",2) S DIC("DR")=DIC("DR")_";.03////"_$P(IBPROC(IBX),"^",2) 152 . E S IBPRICE=1 153 . D FILE^DICN 154 I +Y<1 L -^IBAT(351.61,IBIEN) Q "0^Unable to file procedures" 155 Q IBIEN 156 DX(IBIEN,IBPTF) ; - files dx info 157 Q IBIEN 158 N IBX,Y S Y=1,IBX="" F S IBX=$O(IBDX(IBX)) Q:IBX=""!(+Y<1) D 159 . N DD,DO,DIC,DINUM,X 160 . S DIC="^IBAT(351.61,"_IBIEN_",2,",DIC(0)="",X=$P(IBDX(IBX),"^") 161 . ;S DA(1)=IBIEN,DIC("P")=$P(^DD(351.61,2,0),"^",2) D FILE^DICN 162 . ; no longer required with fm22 163 . S DA(1)=IBIEN D FILE^DICN 164 Q $S(+Y<1:"0^Unable to file diagnosis's",1:IBIEN) 165 ; 166 INIT ; called to possibly initialize the 351.6 file if not done 167 N IBS,ZTRTN,ZTDESC,ZTIO,ZTSK,X,Y 168 ; 169 Q:$O(^IBAT(351.6,0)) ; already populated 170 ; 171 ; is Transfer Pricing active or not for any 172 S IBS=$G(^IBE(350.9,1,10)) 173 I '$P(IBS,"^",2),'$P(IBS,"^",3),'$P(IBS,"^",4),'$P(IBS,"^",5) Q 174 ; 175 ; queue off job 176 W !!,"It appears you have never used Transfer Pricing before. I need to populate",!,"the Transfer Pricing patient file. Please select a date/time to do this.",! 177 S ZTRTN="ADDTP^IBATFILE",ZTDESC="Initializing Transfer Pricing Patient File",ZTIO="" D ^%ZTLOAD 178 I $G(ZTSK) W !,"Task Queued #",ZTSK 179 ; 180 Q 181 ADDTP ; Add Transfer Pricing patients to file #351.6 182 ; 183 N DFN,IBADM,IBDFN,IBPREF,IBADMDT,IBX 184 ; 185 S DFN=0 F S DFN=$O(^DPT(DFN)) Q:'DFN D 186 .; 187 .S IBDFN=$$TPP^IBATUTL(DFN) 188 .Q:'IBDFN 189 .; 190 .; - see if they are admitted 191 .S IBADM=$G(^DPT(DFN,.105)) 192 .I IBADM D 193 ..S IBPREF=+$P($G(^IBAT(351.6,DFN,0)),"^",3) 194 ..S IBADMDT=+$G(^DGPM(IBADM,0)) 195 ..S IBX=$$ADM(DFN,IBADMDT,IBPREF,IBADM_";DGPM(") 196 ; 197 Q
Note:
See TracChangeset
for help on using the changeset viewer.
