- 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/IBATLM1B.m
r613 r623 1 IBATLM1B 2 ;;2.0;INTEGRATED BILLING;**115,261,389**;21-MAR-94;Build 6 3 ;;Per VHA Directive 2004-038, this routine should not be modified.4 5 CF 6 7 8 CS 9 10 11 CT 12 13 14 15 16 17 18 19 20 21 CD 22 23 24 25 26 27 CP 28 29 30 31 32 33 34 35 AT 36 37 38 39 40 41 42 43 I 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 M(X,Y) 63 64 65 66 67 68 O 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 P 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 R 131 N IBBDT,IBEDT,IBCOUNT,IBOUT,IBDA,IBDATA,IBDATA1,IBP,IBC,IBCOUNT,%,DIRUT132 133 134 135 136 137 138 139 140 . S IBDATA=$G(^RMPR(660,+IBDA,0)) Q:IBDATA="" S IBDATA1=$G(^RMPR(660,+IBDA,1)) 141 142 143 144 145 146 . I $S('$D(^RMPR(660,IBDA,"AM")):1,$P(IBDATA,"^",9)="":1,$P(IBDATA,"^",12)="":1,$P(IBDATA1,"^",4)="":1,$P(IBDATA,"^",14)="V":1,$P(IBDATA,"^",15)="*":1,1:0) Q147 148 149 150 151 152 153 154 155 156 157 . W ?20,$E($P($$PIN^IBATUTL($O(IBP(IBC,0))),U,2),1,28),?50,"("158 159 160 161 162 163 164 165 166 167 168 W $$RMPR^IBATFILE(DFN,$P(IBDATA,"^",12),$$PPF^IBATUTL(DFN),(IBDA_";RMPR(660,"),,$P(IBDATA,"^",16))169 170 171 172 H 173 174 175 176 DUP(IBSOURCE,IBQUIT) 177 178 179 180 181 1 IBATLM1B ;LL/ELZ - TRANSFER PRICING TRANSACTION LIST MENU ; 15-SEP-1998 2 ;;2.0;INTEGRATED BILLING;**115,261**;21-MAR-94 3 ;;Per VHA Directive 10-93-142, this routine should not be modified. 4 ; 5 CF ; -- change facility from patient level 6 D LMOPT^IBATUTL,CFP^IBATLM0A(DFN),HDR^IBATLM1 7 Q 8 CS ; -- change status of patient from patient level 9 D LMOPT^IBATUTL,CSP^IBATLM0A(DFN),HDR^IBATLM1 10 Q 11 CT ; -- cancel a transaction 12 N IBVAL,DIE,DA,DR,DTOUT,% 13 D LMOPT^IBATUTL,EN^VALM2($G(XQORNOD(0))) 14 S (DA,IBVAL)=0,IBVAL=$O(VALMY(IBVAL)) Q:'IBVAL 15 S DA=$O(@VALMAR@("INDEX",IBVAL,DA)) 16 I $P(^IBAT(351.61,DA,0),U,5)="X" W !!,"Transaction already cancelled!" D H Q 17 W !!,"Are you sure you want to cancel this transaction" 18 S %=2 D YN^DICN Q:%'=1 19 D CANC^IBATFILE(DA),ARRAY^IBATLM1A(VALMAR) 20 Q 21 CD ; -- change the current date range for transactions displayed 22 N IBSAVE S IBSAVE=IBBDT_"^"_IBEDT 23 D LMOPT^IBATUTL 24 I $$SLDR^IBATUTL S IBBDT=$P(IBSAVE,"^"),IBEDT=$P(IBSAVE,"^",2) 25 D ARRAY^IBATLM1A(VALMAR),HDR^IBATLM1 26 Q 27 CP ; -- change the currently selected patient 28 N IBDFN 29 D LMOPT^IBATUTL 30 S IBDFN=$$SLPT^IBATUTL I 'IBDFN Q 31 I $$SLDR^IBATUTL Q 32 S DFN=IBDFN K ^TMP("VALM DATA",$J),^TMP("VALMAR",$J) 33 D HDR^IBATLM1,ARRAY^IBATLM1A(VALMAR) 34 Q 35 AT ; -- add a transaction 36 N X,Y,DTOUT,DUOUT,DIRUT,DIROUT 37 D LMOPT^IBATUTL 38 S DIR(0)="SMBA^I:Inpatient;O:Outpatient;P:Prescription;R:Prosthetic" 39 S DIR("A")="Select type of Transaction to add: " D ^DIR Q:$D(DIRUT) 40 D @Y K ^TMP("VALM DATA",$J),^TMP("VALMAR",$J) 41 D HDR^IBATLM1,ARRAY^IBATLM1A(VALMAR) 42 Q 43 I ; -- select an inpatient stay and add 44 N IBXA,IBADM,DIRUT,IBIEN,VAIP,IBCHARGE,IBPPF,IBRES 45 S IBXA=7,IBADM=+$$ADSEL^IBECEA31(DFN) Q:IBADM<0 46 I IBADM=0 W !!,"Patient has no admissions on file." D H Q 47 D DUP(IBADM_";DGPM(",.DIRUT) 48 I $D(DIRUT) D H Q 49 S VAIP("E")=IBADM D IN5^VADPT S IBPPF=$$PPF^IBATUTL(DFN) 50 S IBIEN=$$ADM^IBATFILE(DFN,+VAIP(13,1),IBPPF,(+IBADM)_";DGPM(") 51 I 'IBIEN D M(,$P(IBIEN,"^",2)) Q 52 I '$G(VAIP(17)) D M(IBIEN,"missing discharge information") Q 53 S IBRES=$$DIS^IBATFILE(IBIEN,+VAIP(17,1),VAIP(12),VAIP(17)) 54 I 'IBRES D M(IBIEN,$P(IBRES,"^",2)) Q 55 S IBFINDRT=$$FINDRT^IBATEI(VAIP(12),VAIP(13),DFN) 56 I '+IBFINDRT D M(IBIEN,"Cannot price transaction") Q 57 I $P(IBFINDRT,"^",3)="B" S IBRES=$$INPT^IBATFILE(IBIEN,0,0,$P(IBFINDRT,"^",4),0,$P(IBFINDRT,"^",4),$P(IBFINDRT,"^",7)) 58 E S IBRES=$$INPT^IBATFILE(IBIEN,$P(IBFINDRT,"^",3),$P(IBFINDRT,"^",2),$P(IBFINDRT,"^",4),$P(IBFINDRT,"^",5),$P(IBFINDRT,"^",6),$P(IBFINDRT,"^",7)) 59 I 'IBRES D M(IBIEN,"Error in filling pricing information") Q 60 D M(IBIEN) 61 Q 62 M(X,Y) ; Prints message and hangs 63 N IBSITE S IBSITE=$$SITE^IBATUTL 64 I $D(X) W !,"Transaction #",IBSITE,X," Added" 65 I $D(Y) W !,"Cannot complete, ",Y 66 D H 67 Q 68 O ; -- select an outpatient stay 69 N X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT,IBDATA,IBX,IBC,CPTLIST,IBIEN,IBFAC 70 K ^TMP("IBAT",$J) 71 S DIR(0)="D^::AEPX",DIR("A")="Visit Date" D ^DIR Q:$D(DIRUT) 72 S IBDATA("DFN")=DFN,IBDATA("BDT")=Y,IBDATA("EDT")=Y+.99999 73 ; 74 ; scan for the appointments and set up tmp global 75 ; screen to eliminate children and inpatient appointments 76 D SCAN^IBSDU("PATIENT/DATE",.IBDATA,"I '$P(Y0,""^"",6),$P(Y0,""^"",12)'=8","S ^TMP(""IBAT"",$J,Y)=Y0","") 77 ; 78 I '$D(^TMP("IBAT",$J)) W !!,"No appointments exist for the date!" D H Q 79 W !,?10,"Choose which Visit:" S IBX=0 80 F IBC=1:1 S IBX=$O(^TMP("IBAT",$J,IBX)) Q:IBX<1 S IBDATA=^(IBX) D 81 . W !,?4,IBC,?10,$$FMTE^XLFDT($P(IBDATA,"^"),"1P") 82 . W ?35,$$EX^IBATUTL(409.68,.04,$P(IBDATA,"^",4)) 83 . W ?55,$$EX^IBATUTL(409.68,.12,$P(IBDATA,"^",12)) 84 S DIR(0)="N^1:"_(IBC-1),DIR("A")="Select" D ^DIR Q:$D(DIRUT) 85 S IBX=0 F IBC=1:1:Y S IBX=$O(^TMP("IBAT",$J,IBX)) 86 ; check for duplicates 87 D DUP(IBX_";SCE(",.DIRUT) I $D(DIRUT) D H Q 88 ; setup visit info 89 S IBX(0)=^TMP("IBAT",$J,IBX) 90 D GETCPT^SDOE(IBX,"CPTLIST") ;GETDX^SDOE(IBX,"DXLIST") 91 S IBFAC=$$PPF^IBATUTL(DFN) 92 ; ok now lets format cpts and price 93 S IBIEN=0 F S IBIEN=$O(CPTLIST(IBIEN)) Q:IBIEN<1 D 94 . N IBCPT,IBQTY,IBPRICE 95 . S IBCPT=$P(CPTLIST(IBIEN),"^"),IBQTY=$P(CPTLIST(IBIEN),"^",16) 96 . S IBPRICE=$$OPT^IBATCM(IBCPT,$P(IBX(0),"^"),IBFAC) 97 . S IBIEN(IBCPT)=IBQTY_"^"_$S(IBPRICE:$P(IBPRICE,"^",4),1:0) 98 S IBIEN=$$OUT^IBATFILE(DFN,$P(IBX(0),"^"),IBFAC,IBX_";SCE(",.IBIEN) 99 W !!,"Transaction Number ",$P(^IBAT(351.61,IBIEN,0),"^")," Added!" D H 100 K ^TMP("IBAT",$J) 101 Q 102 P ; -- select an rx 103 N IBRX,IBPSRX,IBOUT,IBCOUNT,DIRUT,DIR,IBP,IBNUM,IBSITE,IBQUIT,IBBDT,IBEDT 104 S (IBCOUNT,IBOUT)=0 105 Q:$$SLDR^IBATUTL 106 D RX^IBATRX(DFN,IBBDT,IBEDT,.IBRX) 107 I '$D(IBRX) W !!,"No Rx's on file for date range selected." D H Q 108 W @IOF,!,"Prescriptions Issued:",! 109 S IBPSRX=0 F S IBPSRX=$O(IBRX(IBPSRX)) Q:IBPSRX=""!(IBOUT) D 110 . S IBDT=0 F S IBDT=$O(IBRX(IBPSRX,IBDT)) Q:IBDT<1!(IBOUT) D 111 .. S IBDAT=IBRX(IBPSRX,IBDT),IBCOUNT=IBCOUNT+1 112 .. W !,IBCOUNT,?4,$$FMTE^XLFDT(IBDT,"5D"),?18,$P(IBDAT,"^") 113 .. W "(",$P(IBDAT,"^",2),")",?35,$E($P(IBDAT,"^",4),1,27) 114 .. W ?65,$J($FN($P(IBDAT,"^",5)*$P(IBDAT,"^",6),",",2),12) 115 .. ;I $Y+4>IOSL D H X:'$D(DIRUT) "W @IOF,!" I $D(DIRUT) S IBOUT=1 Q 116 .. S IBNUM(IBCOUNT)=IBPSRX_"^"_IBDT 117 W ! K DIRUT S DIR(0)="L^1:"_IBCOUNT,DIR("A")="Which Prescriptions" 118 D ^DIR Q:$D(DIRUT) W !!,"Selected number(s): "_Y S IBNUM=Y 119 W !,"Ok to add: " S %=1 D YN^DICN I %'=1 D H Q 120 S IBFAC=$$PPF^IBATUTL(DFN),IBSITE=$$SITE^IBATUTL 121 F IBP=1:1 S IBRX=$P(IBNUM,",",IBP) Q:'IBRX D 122 . S IBRX(0)=IBRX($P(IBNUM(IBRX),"^"),$P(IBNUM(IBRX),"^",2)) 123 . D DUP($P(IBRX(0),"^")_";PSRX(;"_$P(IBRX(0),"^",2),.IBQUIT) 124 . I $G(IBQUIT) K IBQUIT Q 125 . W !!,"Adding Transaction number ",IBSITE 126 . W $$RX^IBATFILE(DFN,$P(IBNUM(IBRX),"^",2),IBFAC,$P(IBRX(0),"^")_";PSRX(;"_$P(IBRX(0),"^",2),$P(IBRX(0),"^",3),$P(IBRX(0),"^",5),$P(IBRX(0),"^",6)) 127 . W "!" H 1 128 D H 129 Q 130 R ; -- select an prosthetic 131 N IBBDT,IBEDT,IBCOUNT,IBOUT,IBDA,IBDATA,IBP,IBC,IBCOUNT,%,DIRUT 132 ; 133 S (IBCOUNT,IBOUT)=0 134 Q:$$SLDR^IBATUTL 135 ; 136 ; look up prosthetic devices issued 137 S IBDA="" F S IBDA=$O(^RMPR(660,"C",DFN,IBDA)) Q:'IBDA D 138 . ; 139 . ; valid data 140 . S IBDATA=$G(^RMPR(660,+IBDA,0)) Q:IBDATA="" 141 . ; 142 . ; valid date range 143 . I $P(IBDATA,"^",12)<IBBDT!($P(IBDATA,"^",12)>IBEDT) Q 144 . ; 145 . ; checks from RMPRBIL copied 4/7/2000 with mod for AM node patients 146 . I $S('$D(^RMPR(660,IBDA,"AM")):1,$P(IBDATA,"^",9)="":1,$P(IBDATA,"^",12)="":1,$P(IBDATA,"^",6)="":1,$P(IBDATA,"^",14)="V":1,$P(IBDATA,"^",15)="*":1,1:0) Q 147 . ; 148 . ; set array 149 . S IBCOUNT=IBCOUNT+1,IBP(IBCOUNT,IBDA)=IBDATA 150 ; 151 I 'IBCOUNT W !!,"No Prosthetic Devices on file for date range selected." D H Q 152 ; 153 W @IOF,!,"Prosthetic Devices Issued:",! 154 F IBC=1:1:IBCOUNT Q:IBOUT D 155 . S IBDATA=IBP(IBC,$O(IBP(IBC,0))) 156 . W !,IBC,?4,$$FMTE^XLFDT($P(IBDATA,"^",12),"5D") 157 . W ?20,$$EX^IBATUTL(660,4,$P(IBDATA,"^",6)),?40,"(" 158 . W $$EX^IBATUTL(660,62,$P(^RMPR(660,$O(IBP(IBC,0)),"AM"),"^",3)),")" 159 . W ?65,$J($FN($P(IBDATA,"^",16),",",2),12) 160 ; 161 W ! K DIRUT S DIR(0)="N^1:"_IBCOUNT_":0" 162 S DIR("A")="Which Prosthetic Device" D ^DIR Q:$D(DIRUT) S IBC=+Y 163 W !,"Ok to add: " S %=1 D YN^DICN I %'=1 D H Q 164 S IBDA=$O(IBP(IBC,0)),IBDATA=IBP(IBC,IBDA) 165 D DUP(IBDA_";RMPR(660,",.DIRUT) 166 I $D(DIRUT) D H Q 167 W !!,"Adding Transaction number ",$$SITE^IBATUTL 168 W $$RMPR^IBATFILE(DFN,$P(IBDATA,"^",12),$$PPF^IBATUTL(DFN),(IBDA_";RMPR(660,"),$P(IBDATA,"^",6),$P(IBDATA,"^",16)) 169 W "!" H 1 170 D H 171 Q 172 H ; -- page reader 173 N DIR,X,Y,DTOUT,DUOUT,DIROUT 174 W !! S DIR(0)="E" D ^DIR 175 Q 176 DUP(IBSOURCE,IBQUIT) ; -- checks for dups that are not cancelled 177 N IBT S IBT=0 178 F S IBT=$O(^IBAT(351.61,"AD",IBSOURCE,IBT)) Q:IBT<1!($D(IBQUIT)) D 179 . Q:$P(^IBAT(351.61,IBT,0),"^",5)="X" 180 . W !,$S(IBSOURCE["SCE(":"Visit",IBSOURCE["DGPM(":"Admission",IBSOURCE["RMPR(":"Prosthetic",1:"Prescription")," exists already!" S IBQUIT=1 181 Q
Note:
See TracChangeset
for help on using the changeset viewer.
