- Timestamp:
- Dec 4, 2009, 8:26:01 PM (14 years ago)
- Location:
- FOIAVistA/tag/r
- Files:
-
- 1 edited
- 1 copied
Legend:
- Unmodified
- Added
- Removed
-
FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC5B.m
r628 r636 1 1 IBCSC5B ;ALB/ARH - ADD/ENTER PROSTHETIC ITEMS ;12/28/93 2 ;;2.0;INTEGRATED BILLING;**4,52,260,339 ,389**;21-MAR-94;Build 62 ;;2.0;INTEGRATED BILLING;**4,52,260,339**;21-MAR-94;Build 2 3 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 4 ; 5 5 ; 6 EN ; add/edit prosthetic items for a bill, IBIFN required 7 N IBX,DFN,IBDT1,IBDT2,IBACTION,BIFN,APROS,ALPROS,ABILL,ALBILL 6 EN ;add/edit prosthetic items for a bill, IBIFN required 8 7 S IBX=$$BILL(IBIFN) Q:'IBIFN S DFN=+IBX,IBDT1=$P(IBX,U,2),IBDT2=$P(IBX,U,3) 8 D SET(IBIFN,.IBPDA),PIDISP(DFN,IBDT1,IBDT2,.IBPDE,.IBPDA),DISP(.IBPDA) 9 E1 S IBPIFN=0,IBDT=$$ASKDT(IBDT1,IBDT2) G:'IBDT EXIT 10 S IBPD=$O(IBPDA(IBDT,0)) S:'IBPD IBPD=$O(IBPDE(IBDT,0)) S IBPD=$$ASKPD(IBPD) G:'IBPD E1 11 S IBPIFN=$G(IBPDA(IBDT,+IBPD)) I 'IBPIFN S IBPIFN=$$ADD(IBDT,IBIFN,+IBPD,+$G(IBPDE(IBDT,+IBPD))) I 'IBPIFN W " ??" G E1 12 I '$D(IBPDE(IBDT,+IBPD)) W !,"This prosthetic item does not exist in this patients prosthetics record.",! 13 D EDIT(+IBPIFN) D SET(IBIFN,.IBPDA) W ! G E1 9 14 ; 10 EN1 D PISET(DFN,IBDT1,IBDT2,.APROS,.ALPROS) D SET(IBIFN,.ABILL,.ALBILL,+$G(APROS)) 11 D PIDISP(.APROS,.ALPROS,.ABILL) D DISP(.ABILL,.ALBILL) S BIFN="" 12 ; 13 S IBACTION=$$SELECT(.ALPROS,.ALBILL) Q:'IBACTION 14 I +IBACTION=1 S BIFN=$$ADD(IBIFN,$P(IBACTION,U,2),$P(IBACTION,U,3)) G EN1 15 I +IBACTION=2 S BIFN=+$G(ABILL(+$P(IBACTION,U,2),$P(IBACTION,U,3))) 16 I +IBACTION=3 S IBX=$$ASKITM(IBDT1,IBDT2) I +IBX S BIFN=$$ADD(IBIFN,+IBX,,$P(IBX,U,2)) 17 I +BIFN D EDIT(BIFN) 18 ; 19 G EN1 15 EXIT K IBPIFN,IBX,IBDT1,IBDT2,IBPDA,IBPDE,IBPD,IBDT 20 16 Q 21 17 ; 22 SELECT(ALPROS,ALBILL) ; get which item to add/edit, select from Patient Prosthetics, Bill Items, or add a new one 23 ; returns 1 ^ PD DEL DATE ^ PI IFN - ALPROS(selected item) if item from Prosthetics selected 24 ; 2 ^ PD DEL DATE ^ X - ALBILL(selected item) if item existing on bill selected 25 ; 3 if add new item, "" if exit, -1 if redo 26 N IBX,IBY,IBZ,DIR,DTOUT,DUOUT,DIRUT,X,Y S IBY="" 27 S DIR("?")="Select the Prosthetics Item to Add or Edit." 28 S DIR("?",1)="Enter the number preceding the Item to Add or Edit." 29 S DIR("?",2)="Or enter the Item name to add an item not in the list and not in Prosthetics.",DIR("?",3)=" " 18 ASKDT(IBDT1,IBDT2,IBDT) ; 19 I +$G(IBIFN) S DIR("?")="Enter the date the item was delivered to the patient",DIR("??")="^D HELP^IBCSC5B("_IBIFN_")" 20 S DIR("A")="Select ITEM DELIVERY DATE",DIR(0)="DO^"_IBDT1_":"_IBDT2_":EX" D ^DIR K DIR,DTOUT,DIRUT 21 Q $S(Y?7N:Y,1:0) 30 22 ; 31 S DIR("A")="Select Prosthetics Item",DIR(0)="FO^1:20^K:X?1N1P.NP X" D ^DIR S IBX=Y I $D(DIRUT) G SELECTQ 23 ASKPD(PD) ; 24 N X,Y 25 S DIR("A")="Select PROSTHETIC ITEM",DIR(0)="660,4O" S:+$G(PD) DIR("B")=+$G(^RMPR(661,+$G(PD),0)) D ^DIR S:$D(DIRUT)!(Y'>0) Y="" K DIR,DIRUT 26 Q Y 32 27 ; 33 S IBZ=$G(ALPROS(IBX)) I +IBZ W " adding ",IBX S IBY="1^"_IBZ G SELECTQ 34 S IBZ=$G(ALBILL(IBX)) I +IBZ W " editing ",IBX S IBY="2^"_IBZ G SELECTQ 28 ADD(IBDT,IFN,IBPD,PIFN) ; 29 N IBX,IBY,IBDX,IBHCPCS S IBX=0,DIC="^IBA(362.5,",DIC(0)="AQL",X=IBDT K DA,DO D FILE^DICN K DA,DO,X 30 I Y>0 S DIE=DIC,(IBX,DA)=+Y,DR=".02////"_IFN_";.03////"_IBPD_";.04////"_PIFN D ^DIE K DIE,DIC,DA,DR W "... ADDED" 31 ;add dx if known 32 F IBY=1:1:4 S IBDX=+$G(^RMPR(660,PIFN,"BA"_IBY)) I IBDX,'$O(^IBA(362.3,"AIFN"_IFN,IBDX)) D 33 . S DIC="^IBA(362.3,",DIC(0)="L",DLAYGO=362.3,X=IBDX,DIC("DR")=".02////"_IFN K DD,DO D FILE^DICN S IBDX(+Y)="" 34 ;add hcpcs if known 35 ;S IBHCPCS=$P($G(^RMPR(660,PIEN,0)),"^",22) I IBHCPCS 35 36 ; 36 S DIR(0)="YO",DIR("A")="Add a New Item",DIR("B")="YES" D ^DIR K DIR S IBY=-1 I Y=1,'$D(DIRUT) S IBY=337 Q IBX 37 38 ; 38 SELECTQ Q IBY 39 ; 40 ASKITM(IBDT1,IBDT2) ; Ask for new item data when adding an item not in Prosthetics 41 ; returns: delivery date ^ prosthetic item name (from 661.1, .02) 42 N DIR,DIC,DIE,DTOUT,DUOUT,DIRUT,X,Y,IBX,IBY S (IBX,IBY)="" I '$G(IBDT1)!'$G(IBDT2) G ASKITMQ 43 ; 44 W !!,"Enter a Prosthetics Item that does not have a Prosthetics Patient record.",! 45 S DIR("A")="Select ITEM DELIVERY DATE",DIR(0)="DO^"_IBDT1_":"_IBDT2_":EX" D ^DIR S IBX=Y I Y'?7N G ASKITMQ 46 ; 47 S DIC="^RMPR(661.1,",DIC(0)="AENOQMZ",DIC("S")="I +$P(^(0),U,5)",DIC("A")="Select PROSTHETICS ITEM: " D ^DIC 48 ; 49 I +Y>0,+IBX S IBY=IBX_U_$P($G(Y(0)),U,2) 50 ; 51 ASKITMQ Q IBY 52 ; 53 ADD(IBIFN,IBDT,PIFN,IBPNAME) ; Add new Item to Bill (#362.5) 54 N IBX,IBY,IBDX,IBHCPCS,DIC,DIE,DA,DR,DLAYGO,X,Y S IBY=0,PIFN=+$G(PIFN) I ($G(IBDT)'?7N)!('$G(IBIFN)) G ADDQ 55 ; 56 I $G(PIFN),$$ONBILLPI(IBIFN,PIFN) G ADDQ ; don't add duplicates 57 I $G(IBPNAME)="" S IBPNAME=$P($$PIN(PIFN),U,2) I IBPNAME="" G ADDQ 58 ; 59 S DIC="^IBA(362.5,",DIC(0)="AQL",DLAYGO=362.5,X=IBDT K DA,DO D FILE^DICN K DA,DO,X 60 I Y>0 S (IBY,DA)=+Y,DIE=DIC,DR=".02////"_IBIFN_";.04////"_+PIFN_";.05///^S X=IBPNAME" D ^DIE K DIE,DA,DR W "... ADDED" 61 ; 62 ;add dx if known 63 I +IBY,+PIFN F IBX=1:1:4 S IBDX=+$G(^RMPR(660,PIFN,"BA"_IBX)) I IBDX,'$O(^IBA(362.3,"AIFN"_IBIFN,IBDX)) D 64 . S DIC="^IBA(362.3,",DIC(0)="L",DLAYGO=362.3,X=IBDX,DIC("DR")=".02////"_IBIFN K DD,DO D FILE^DICN S IBDX(+Y)="" 65 ;add hcpcs if known ;S IBHCPCS=$P($G(^RMPR(660,PIEN,0)),"^",22) I IBHCPCS 66 ; 67 ADDQ Q IBY 68 ; 69 EDIT(BIFN) ; 70 N DIDEL,DIE,DIC,DR,DA,X,Y Q:'$G(BIFN) W ! S DIDEL=362.5,DIE="^IBA(362.5,",DR=".01;.05",DA=BIFN D ^DIE 39 EDIT(PIFN) ; 40 S DIDEL=362.5,DIE="^IBA(362.5,",DR=".01;.03",DA=PIFN D ^DIE K DIE,DR,DA,DIC,DIDEL 71 41 Q 72 42 ; 73 SET(IBIFN,ARRB,ARRBL,PICNT) ; setup array of all prosthetic devices on bill (#362.5), array names should be passed by reference 74 ; input: PICNT - the number of items found in prosthetics (PISET) 75 ; output: ARRB(PD DELIV DATE, X) = PD IFN (362.5 ptr) ^ Cost, ARRB = BILL IFN ^ count of items on bill 76 ; ARRBL(PICNT + count of item on bill) = PD DELIV DATE ^ X 77 ; where X is the IFN of the Patient Item (660 ptr) or if not defined then a number_"Z" 78 N CNT,IBX,IBY,BIFN,RIFN,IBC,IBRC K ARRB,ARRBL S IBC="AIFN"_$G(IBIFN),ARRB="^0" Q:'$G(IBIFN) 79 D RCITEM^IBCSC5A(IBIFN,"IBRC",5) S CNT=0 80 ; 81 S IBX=0 F S IBX=$O(^IBA(362.5,IBC,IBX)) Q:'IBX S BIFN=0 F S BIFN=$O(^IBA(362.5,IBC,IBX,BIFN)) Q:'BIFN D 82 . S IBY=$G(^IBA(362.5,BIFN,0)) Q:IBY="" S CNT=CNT+1,RIFN=+$P(IBY,U,4),RIFN=$S(+RIFN:+RIFN,1:CNT_"Z") 83 . S ARRB(+IBY,RIFN)=BIFN_U_$$CHG^IBCF4(BIFN,5,.IBRC),ARRB=$G(ARRB)+1 84 S ARRB=IBIFN_U_+$G(ARRB) 85 ; 86 S CNT=+$G(PICNT),IBX=0 F S IBX=$O(ARRB(IBX)) Q:'IBX S IBY=0 F S IBY=$O(ARRB(IBX,IBY)) Q:'IBY S CNT=CNT+1,ARRBL(CNT)=IBX_U_IBY 43 SET(IFN,PDARR) ;setup array of all prosthetic devices for bill, array name should be passed by reference 44 ;returns: PDARR(PD DELIV DATE, PD ITEM (661 ptr))=PD IFN (362.5 ptr), PDARR=BILL IFN ^ PD count 45 N CNT,IBX,IBY,PIFN,IBC,IBRC K PDARR S IBC="AIFN"_$G(IFN) 46 D RCITEM^IBCSC5A(IBIFN,"IBRC",5) 47 S (CNT,IBX)=0 F S IBX=$O(^IBA(362.5,IBC,IBX)) Q:'IBX S PIFN=0 F S PIFN=$O(^IBA(362.5,IBC,IBX,PIFN)) Q:'PIFN D 48 . S IBY=$G(^IBA(362.5,PIFN,0)) Q:IBY="" S CNT=CNT+1,PDARR(+IBY,$P(IBY,U,3))=PIFN_U_$$CHG^IBCF4(PIFN,5,.IBRC) 49 S PDARR=$G(IFN)_"^"_CNT 87 50 Q 88 51 ; 89 DISP(ABILL,ALBILL) ;screen display of existing prosthetic devices for a bill, arrays should be passed by reference 90 ; input: ABILL (from SET) list of bill items 91 ; ALBILL (from SET) list of bill items, in count order 92 N IBC,IBI,BIFN,BIFN0,DDT 93 ; 52 DISP(PDARR) ;screen display of existing prosthetic devices for a bill, 53 ;input should be array returned by SET^IBCSC5B: PDARR(PD DT, PD ITEM)=PD IFN (362.5), pass by reference 54 N IBX,IBY,IBZ 94 55 W !!,?5,"----------------- Existing Prosthetic Items for Bill -----------------",! 95 S IBC=0 F S IBC=$O(ALBILL(IBC)) Q:'IBC D 96 . S DDT=+ALBILL(IBC),IBI=$P(ALBILL(IBC),U,2),BIFN=+$G(ABILL(DDT,IBI)),BIFN0=$G(^IBA(362.5,BIFN,0)) 97 . W !,?1,$J(IBC,2),")",?6,$$DATE(DDT),?16,$E($P(BIFN0,U,5),1,60) 56 S IBX=0 F S IBX=$O(PDARR(IBX)) Q:IBX="" S IBY=0 F S IBY=$O(PDARR(IBX,IBY)) Q:'IBY D 57 . S IBZ=$$PIN(IBY) W !,$$DATE(IBX),?12,$P(IBZ,U,1),?20,$P(IBZ,U,2) 98 58 W ! 99 59 Q 100 60 ; 101 PISET(DFN,DT1,DT2,ARRP,ARRPL) ; get all prosthetic items (660) for a patient and date range, arrays should pass by ref. 102 ; input: DFN = patient, DT1-DT2 range of dates to search for items 103 ; output: ARRP(PD DEL DATE (660,10), PI IFN (660 ptr)) = PI IFN (660 ptr), ARRP = count of items 104 ; ARRPL(count) = PD DEL DATE (660,10) ^ PI IFN (660 ptr) 105 ; 106 N PIFN,DDT,IBX,IBY,CNT K ARRP,ARRPL Q:'$G(DFN) S DT1=$G(DT1)-.0001,DT2=$G(DT2) S:'DT2 DT2=9999999 107 S PIFN=0 F S PIFN=$O(^RMPR(660,"C",DFN,PIFN)) Q:'PIFN D 108 . S IBX=$G(^RMPR(660,PIFN,0)) Q:IBX="" S DDT=+$P(IBX,U,12)\1 I (DDT<DT1)!(DDT>DT2) Q 109 . S ARRP(DDT,PIFN)=PIFN,ARRP=+$G(ARRP)+1 110 ; 111 S (CNT,IBX)=0 F S IBX=$O(ARRP(IBX)) Q:'IBX S IBY=0 F S IBY=$O(ARRP(IBX,IBY)) Q:'IBY S CNT=CNT+1,ARRPL(CNT)=IBX_U_IBY 61 HELP(IFN) ;called for help from prosthetics enter to display existing devices, displays devices from 660 and 399 62 I +$G(IFN) N IBX,IBPDA S IBX=$$BILL(IFN) I +IBX D SET(IFN,.IBPDA),PIDISP($P(IBX,U,1),$P(IBX,U,2),$P(IBX,U,3),"",.IBPDA),DISP(.IBPDA) 112 63 Q 113 64 ; 114 PIDISP(APROS,ALPROS,ABILL) ; display all prosthetic items (#660) for a patient and date range, arrays passed by reference, not changed 115 ; input: APROS (from PISET) patient's prosthetic items 116 ; ALPROS (from PISET) patient's prosthetics items, in count order 117 ; ABILL (from SET) list of bill's prosthetics items, only to check if item on bill 118 N IBC,DDT,PIFN,PNAME,IBY,IBX,IBICD,IBP,IBEX 65 PIDISP(DFN,DT1,DT2,ARRAY,PDARR) ; display all prosthetic items (660) for a patient and date range 66 ;PDARR (as defined by SET^IBCSC5B) passed by ref. only to check if pros. item is on the bill, not necessary, not changed 67 ;returns ARRAY(PD DEL DATE (660,10), PD ITEM (660,4=661 ptr))=RECORD (660 ptr), should pass by ref. if desired 68 N PIFN,IBX,IBY,PNAME,DDT,PI,IBICD,IBEX,IBP 69 K ARRAY S DT1=$G(DT1)-.0001,DT2=$G(DT2) S:'DT2 DT2=9999999 Q:'$G(DFN) 70 S PIFN=0 F S PIFN=$O(^RMPR(660,"C",DFN,PIFN)) Q:'PIFN D 71 . S IBX=$G(^RMPR(660,PIFN,0)),DDT=+$P(IBX,U,12)\1 I (DDT<DT1)!(DDT>DT2) Q 72 . S ARRAY(DDT,+$P(IBX,U,6))=PIFN 119 73 ; 120 W @IOF,?33,"PROSTHETICS SCREEN" 121 W !,"================================================================================",! 122 S IBC=0 F S IBC=$O(ALPROS(IBC)) Q:'IBC D 123 . S DDT=+ALPROS(IBC),PIFN=$P(ALPROS(IBC),U,2) 124 . S PNAME=$$PIN(PIFN),IBY=$G(^RMPR(660,PIFN,"AM")),IBX=$G(^RMPR(660,PIFN,0)) K IBEX 125 . ; 126 . F IBICD=1:1:4 Q:$D(IBEX) I $D(^RMPR(660,PIFN,"BA"_IBICD)) F IBP=2:1:8 I $P(^RMPR(660,PIFN,"BA"_IBICD),"^",IBP) S IBEX="("_$P($T(EXEMPT+(IBP-1)),";",3)_")" Q ; look for exemption info 127 . ; 128 . W !,$S($D(ABILL(+DDT,PIFN)):"*",1:"") 129 . W ?1,$J(IBC,2),")",?6,$$DATE(DDT),?16,$E($P(PNAME,U,2),1,27),?45,"("_$P(PNAME,U,3),")",?53,$G(IBEX),?59,$E($$EXSET^IBEFUNC($P(IBX,U,14),660,12),1,4),?64,$$EXSET^IBEFUNC($P(IBY,U,3),660,62),?71,$J(+$P(IBX,U,16),8,2) 74 W @IOF,?33,"PROSTHETICS SCREEN",!,"================================================================================",! 75 S DDT=0 F S DDT=$O(ARRAY(DDT)) Q:'DDT S PI=0 F S PI=$O(ARRAY(DDT,PI)) Q:'PI D 76 . S PIFN=ARRAY(DDT,PI),PNAME=$$PIN(PI),IBY=$G(^RMPR(660,PIFN,"AM")),IBX=$G(^RMPR(660,PIFN,0)) K IBEX 77 . ; look for exemption info 78 . F IBICD=1:1:4 Q:$D(IBEX) I $D(^RMPR(660,PIFN,"BA"_IBICD)) F IBP=2:1:8 I $P(^RMPR(660,PIFN,"BA"_IBICD),"^",IBP) S IBEX="("_$P($T(EXEMPT+(IBP-1)),";",3)_")" Q 79 . W !,$S($D(PDARR(+DDT,PI)):"*",1:"") 80 . W ?2,$$DATE(DDT),?12,$P(PNAME,U,1),$G(IBEX),?20,$E($P(PNAME,U,2),1,30),?55,$E($$EXSET^IBEFUNC($P(IBX,U,14),660,12),1,4),?62,$$EXSET^IBEFUNC($P(IBY,U,3),660,62),?70,$J(+$P(IBX,U,16),9,2) 130 81 Q 131 82 ; 132 PIN(P660,P6611) ; given Prosthetic record (#660) or PSAS HCPCS (#661.1) return Item Name 133 ; returns PSAS HCPSC ptr (661.1) ^ SHORT DESCRIPTION (661.1, .02) ^ HCPCS (661.1, .01) 134 N IBX,IBY S IBY="" 135 I +$G(P660) S P6611=+$P($G(^RMPR(660,+P660,1)),U,4) 136 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) 83 PIN(PITEM) ;given the pros item IFN (661 ptr) returns name for printing (661,.01^441,.05) 84 N IBX,IBY S IBY="" I +$G(PITEM) S IBX=+$G(^RMPR(661,+PITEM,0)) I +IBX S IBY=IBX_U_$$DESCR^PRCPUX1(0,+IBX) 137 85 Q IBY 138 86 ; 139 PINB(P3625) ; given the bill prosthetics item (#362.5) return Item Name (.05) 140 N IBY S IBY=$P($G(^IBA(362.5,+$G(P3625),0)),U,5) 141 Q IBY 142 ; 143 BILL(IBIFN) ; get bill data: returns DFN ^ Statement Covers From ^ Statement Covers To 144 N IBX,IBY S IBIFN=+$G(IBIFN) S IBX=$G(^DGCR(399,IBIFN,0)),IBY=$P(IBX,U,2) 145 S IBX=$G(^DGCR(399,IBIFN,"U")),$P(IBY,U,2)=+IBX,$P(IBY,U,3)=+$P(IBX,U,2) 146 Q IBY 147 ; 148 ONBILLPI(IBIFN,PIFN) ; return Bill Item ptr (#362.5) if the Prosthetics Item (#660) is already assigned to the bill 149 ; input: PIFN = Patient Prosthetics Item (ptr to 660) 150 ; output: BIFN = Bill Prosthetics Item (ptr to 362.5) or null if not found 151 N IBC,IBX,IBY,BIFN S IBY="" S IBC="AIFN"_$G(IBIFN) 152 S IBX=0 F S IBX=$O(^IBA(362.5,IBC,IBX)) Q:'IBX S BIFN=0 F S BIFN=$O(^IBA(362.5,IBC,IBX,BIFN)) Q:'BIFN D 153 . I +$G(PIFN),$P($G(^IBA(362.5,BIFN,0)),U,4)=PIFN S IBY=BIFN 87 BILL(IBIFN) ; display all existing prescription refills (52) for a patient and date range 88 ; (call is a short cut to calling rxdisp if have bill number) 89 N IBX,IBY S IBX=$G(^DGCR(399,+$G(IBIFN),0)),IBY=$P(IBX,U,2) 90 S IBX=$G(^DGCR(399,+IBIFN,"U")),$P(IBY,U,2)=+IBX,$P(IBY,U,3)=+$P(IBX,U,2) 154 91 Q IBY 155 92 ;
Note:
See TracChangeset
for help on using the changeset viewer.