source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC5B.m@ 691

IBCSC5B ;ALB/ARH - ADD/ENTER PROSTHETIC ITEMS ;12/28/93

 ;;2.0;INTEGRATED BILLING;**4,52,260,339**;21-MAR-94;Build 2

 ;;Per VHA Directive 2004-038, this routine should not be modified.

 ;

 ;

EN ;add/edit prosthetic items for a bill, IBIFN required

 S IBX=$$BILL(IBIFN) Q:'IBIFN  S DFN=+IBX,IBDT1=$P(IBX,U,2),IBDT2=$P(IBX,U,3)

 D SET(IBIFN,.IBPDA),PIDISP(DFN,IBDT1,IBDT2,.IBPDE,.IBPDA),DISP(.IBPDA)

E1 S IBPIFN=0,IBDT=$$ASKDT(IBDT1,IBDT2) G:'IBDT EXIT

 S IBPD=$O(IBPDA(IBDT,0)) S:'IBPD IBPD=$O(IBPDE(IBDT,0)) S IBPD=$$ASKPD(IBPD) G:'IBPD E1

 S IBPIFN=$G(IBPDA(IBDT,+IBPD)) I 'IBPIFN S IBPIFN=$$ADD(IBDT,IBIFN,+IBPD,+$G(IBPDE(IBDT,+IBPD))) I 'IBPIFN W " ??" G E1

 I '$D(IBPDE(IBDT,+IBPD)) W !,"This prosthetic item does not exist in this patients prosthetics record.",!

 D EDIT(+IBPIFN) D SET(IBIFN,.IBPDA) W ! G E1

 ;

EXIT K IBPIFN,IBX,IBDT1,IBDT2,IBPDA,IBPDE,IBPD,IBDT

 Q

 ;

ASKDT(IBDT1,IBDT2,IBDT) ;

 I +$G(IBIFN) S DIR("?")="Enter the date the item was delivered to the patient",DIR("??")="^D HELP^IBCSC5B("_IBIFN_")"

 S DIR("A")="Select ITEM DELIVERY DATE",DIR(0)="DO^"_IBDT1_":"_IBDT2_":EX" D ^DIR K DIR,DTOUT,DIRUT

 Q $S(Y?7N:Y,1:0)

 ;

ASKPD(PD) ;

 N X,Y

 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

 Q Y

 ;

ADD(IBDT,IFN,IBPD,PIFN) ;

 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

 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"

 ;add dx if known

 F IBY=1:1:4 S IBDX=+$G(^RMPR(660,PIFN,"BA"_IBY)) I IBDX,'$O(^IBA(362.3,"AIFN"_IFN,IBDX)) D

 . 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)=""

 ;add hcpcs if known

 ;S IBHCPCS=$P($G(^RMPR(660,PIEN,0)),"^",22) I IBHCPCS

 ;

 Q IBX

 ;

EDIT(PIFN) ;

 S DIDEL=362.5,DIE="^IBA(362.5,",DR=".01;.03",DA=PIFN D ^DIE K DIE,DR,DA,DIC,DIDEL

 Q

 ;

SET(IFN,PDARR) ;setup array of all prosthetic devices for bill, array name should be passed by reference

 ;returns: PDARR(PD DELIV DATE, PD ITEM (661 ptr))=PD IFN (362.5 ptr),  PDARR=BILL IFN ^ PD count

 N CNT,IBX,IBY,PIFN,IBC,IBRC K PDARR S IBC="AIFN"_$G(IFN)

 D RCITEM^IBCSC5A(IBIFN,"IBRC",5)

 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

 . 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)

 S PDARR=$G(IFN)_"^"_CNT

 Q

 ;

DISP(PDARR) ;screen display of existing prosthetic devices for a bill,

 ;input should be array returned by SET^IBCSC5B: PDARR(PD DT, PD ITEM)=PD IFN (362.5), pass by reference

 N IBX,IBY,IBZ

 W !!,?5,"-----------------  Existing Prosthetic Items for Bill  -----------------",!

 S IBX=0 F  S IBX=$O(PDARR(IBX)) Q:IBX=""  S IBY=0 F  S IBY=$O(PDARR(IBX,IBY)) Q:'IBY  D

 . S IBZ=$$PIN(IBY) W !,$$DATE(IBX),?12,$P(IBZ,U,1),?20,$P(IBZ,U,2)

 W !

 Q

 ;

HELP(IFN) ;called for help from prosthetics enter to display existing devices, displays devices from 660 and 399

 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)

 Q

 ;

PIDISP(DFN,DT1,DT2,ARRAY,PDARR) ; display all prosthetic items (660) for a patient and date range

 ;PDARR (as defined by SET^IBCSC5B) passed by ref. only to check if pros. item is on the bill, not necessary, not changed

 ;returns ARRAY(PD DEL DATE (660,10), PD ITEM (660,4=661 ptr))=RECORD (660 ptr), should pass by ref. if desired

 N PIFN,IBX,IBY,PNAME,DDT,PI,IBICD,IBEX,IBP

 K ARRAY S DT1=$G(DT1)-.0001,DT2=$G(DT2) S:'DT2 DT2=9999999 Q:'$G(DFN)

 S PIFN=0 F  S PIFN=$O(^RMPR(660,"C",DFN,PIFN)) Q:'PIFN  D

 . S IBX=$G(^RMPR(660,PIFN,0)),DDT=+$P(IBX,U,12)\1 I (DDT<DT1)!(DDT>DT2) Q

 . S ARRAY(DDT,+$P(IBX,U,6))=PIFN

 ;

 W @IOF,?33,"PROSTHETICS SCREEN",!,"================================================================================",!

 S DDT=0 F  S DDT=$O(ARRAY(DDT)) Q:'DDT  S PI=0 F  S PI=$O(ARRAY(DDT,PI)) Q:'PI  D

 . S PIFN=ARRAY(DDT,PI),PNAME=$$PIN(PI),IBY=$G(^RMPR(660,PIFN,"AM")),IBX=$G(^RMPR(660,PIFN,0)) K IBEX

 . ; look for exemption info

 . 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

 . W !,$S($D(PDARR(+DDT,PI)):"*",1:"")

 . 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)

 Q

 ;

PIN(PITEM) ;given the pros item IFN (661 ptr) returns name for printing (661,.01^441,.05)

 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)

 Q IBY

 ;

BILL(IBIFN) ; display all existing prescription refills (52) for a patient and date range

 ; (call is a short cut to calling rxdisp if have bill number)

 N IBX,IBY S IBX=$G(^DGCR(399,+$G(IBIFN),0)),IBY=$P(IBX,U,2)

 S IBX=$G(^DGCR(399,+IBIFN,"U")),$P(IBY,U,2)=+IBX,$P(IBY,U,3)=+$P(IBX,U,2)

 Q IBY

 ;

DATE(X) ;

 Q $E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)

 ;

EXEMPT ; exemption reasons

 ;;AO

 ;;IR

 ;;SC

 ;;SWA

 ;;MST

 ;;HNC

 ;;CV

 ;