Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBTRE20

IBTRE20.m

Go to the documentation of this file.
  1. IBTRE20 ;ALB/AAS - CLAIMS TRACKING EXECUTABLE HELP ;13-OCT-93
  1. ;;2.0;INTEGRATED BILLING;**40,91,249,568,662**;21-MAR-94;Build 8
  1. ;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. ;
  1. LISTA ; -- list inpatient admissions for patient
  1. N C,I,J,N,X,Y,IBX
  1. K ^TMP("IBM",$J)
  1. Q:'$D(DFN)
  1. S C=0 F I=0:0 S I=$O(^DGPM("ATID1",DFN,I)) Q:'I S N=$O(^(I,0)) I $D(^DGPM(+N,0)) S D=^(0),C=C+1,^TMP("IBM",$J,C)=N_"^"_D
  1. ;
  1. I C=0 W !!,"No Admissions to Choose From." Q
  1. ;
  1. W !!,"CHOOSE FROM:" F IBI=1:1:10 Q:'$D(^TMP("IBM",$J,IBI)) D WRA
  1. K ^TMP("IBM",$J)
  1. Q
  1. ;
  1. WRA S IBX=$P(^TMP("IBM",$J,IBI),"^",2,20),Y=+IBX X ^DD("DD")
  1. W !," ",Y
  1. W ?27,$S('$D(^DG(405.1,+$P(IBX,"^",4),0)):"",$P(^(0),"^",7)]"":$P(^(0),"^",7),1:$E($P(^(0),"^",1),1,20))
  1. ;
  1. W ?50,"TO: ",$E($P($G(^DIC(42,+$P(IBX,"^",6),0)),"^"),1,17)
  1. I $D(^DG(405.4,+$P(IBX,"^",7),0)) W " [",$E($P(^(0),"^",1),1,10),"]"
  1. I $P(IBX,"^",18)=9 W !?23,"FROM: ",$P($G(^DIC(4,+$P(IBX,"^",5),0)),"^")
  1. Q
  1. ;
  1. LISTO ; -- list outpatient appointments
  1. N C,I,J,N,X,Y,IBX,IBI,IBDT
  1. ; assumes ^TMP($J,"SDAMA301",DFN,IBTDT) defined and IBSD(result from SD)
  1. Q:'$D(DFN)
  1. ;
  1. I IBSD<0 W !!,"Unable to look-up Outpatient Visits to Choose From." D Q
  1. . N IBX F S IBX=$O(^TMP($J,"SDAMA301",IBX)) Q:'IBX W !?5,IBX,?10,$G(^(IBX))
  1. ;
  1. I IBSD=0 W !!,"No Outpatient Visits to Choose From." Q
  1. ;
  1. W !!,"CHOOSE FROM:" S IBI=0,IBDT=$G(IBTBDT) F S IBDT=$O(^TMP($J,"SDAMA301",DFN,IBDT)),IBI=IBI+1 Q:'IBDT!(IBI>12) D WRO
  1. Q
  1. ;
  1. WRO N IBSDD,Y
  1. S Y=IBDT X ^DD("DD") W !," ",Y
  1. S IBSDD=$G(^TMP($J,"SDAMA301",DFN,IBDT))
  1. W ?27,"Clinic: ",$P($P(IBSDD,"^",2),";",2),?60," Type: ",$E($P($P(IBSDD,"^",10),";",2),1,12)
  1. ;
  1. S IBSDD=$P(IBSDD,"^",3) I $L(IBSDD),$P(IBSDD,";")'="R" W !,?10," [Status: ",$P(IBSDD,";",2),"]"
  1. Q
  1. ;
  1. LISTS ; -- list scheduled admissions
  1. N C,I,J,N,X,Y,IBX,IBI
  1. K ^TMP("IBM",$J)
  1. Q:'$D(DFN)
  1. S C=0 F I=0:0 S I=$O(^DGS(41.1,"B",DFN,I)) Q:'I I $D(^DGS(41.1,+I,0)) S D=$G(^DGS(41.1,+I,0)) I $P(D,"^",2)'<IBTBDT,$P(D,"^",2)'>IBTEDT S C=C+1,^TMP("IBM",$J,C)=I_"^"_D
  1. ;
  1. I C=0 W !!,"No Scheduled Admissions to Choose From." Q
  1. ;
  1. W !!,"CHOOSE FROM:" F IBI=1:1:12 Q:'$D(^TMP("IBM",$J,IBI)) D WRS
  1. K ^TMP("IBM",$J)
  1. Q
  1. ;
  1. WRS S IBX=$P($G(^TMP("IBM",$J,IBI)),"^",2,20),Y=$P(IBX,"^",2) X ^DD("DD")
  1. W !," ",Y
  1. W ?27," Spec: ",$E($P($G(^DIC(45.7,+$P(IBX,"^",9),0)),"^"),1,25)
  1. ;
  1. W ?58," To: ",$E($P($G(^DIC(42,+$P(IBX,"^",8),0)),"^"),1,16)
  1. Q
  1. ;
  1. FINDS ; -- match a scheduled admission
  1. Q:'$D(DFN)
  1. Q:'$D(IBTDT)
  1. N I,J
  1. S I=0 F S I=$O(^DGS(41.1,"B",DFN,I)) Q:'I S J=$P($G(^DGS(41.1,I,0)),"^",2) Q:IBTDT=J I $P(IBTDT,".")=$P(J,".") S IBTDT=J Q
  1. Q
  1. ;
  1. ID ; -- write out identifier for entry, called by ^dd(356,0,"id","write")
  1. N IBOE,IBOE0
  1. S IBOE=$P(^(0),"^",4),IBOE0=$$SCE^IBSDU(+IBOE) I IBOE,$P(IBOE0,U,4) W ?58,"["_$E($P($G(^SC(+$P(IBOE0,U,4),0)),U),1,20),"]"
  1. Q
  1. ;
  1. PRINT ; patch 40, custom look up. Input: IBX -- 0th node in file #356.
  1. Q:$D(IBX)[0
  1. N NAM,EPIS,EVENT,DISPL,CLIN
  1. S NAM=$E($P($G(^DPT(+$P(IBX,U,2),0)),U),1,22)
  1. S EPIS=$P($P(IBX,U,6),".")
  1. I EPIS S EPIS=$E(EPIS,4,5)_"-"_$E(EPIS,6,7)_"-"_$E(EPIS,2,3)
  1. S EVENT=$E($P($G(^IBE(356.6,+$P(IBX,U,18),0)),U),1,5)
  1. S DISPL=$$EXPAND^IBTRE(356,.07,$P(IBX,U,7))
  1. S CLIN=+$$SCE^IBSDU(+$P(IBX,"^",4),4)
  1. I CLIN S DISPL="["_$E($P($G(^SC(CLIN,0)),U),1,22)_"]"
  1. W ?13,NAM,?37,EPIS,?47,EVENT,?54,DISPL
  1. Q
  1. ;
  1. LISTP ; -- list inpatient admissions for patient
  1. N I,X,Y,P,P1,P2,DDT,DDTO,IBX,SDT,TP,TYPE
  1. K ^TMP("IBPRO",$J)
  1. Q:'$D(DFN)
  1. S (I,C)=0
  1. F S I=$O(^RMPR(660,"C",DFN,I)) Q:'I I $D(^RMPR(660,I,0)) S D=^(0) D
  1. .S SDT=$P(D,U,12) I SDT<IBTBDT!(SDT>IBTEDT) Q
  1. .I $O(^IBT(356,"APRO",I,0)) Q
  1. .S C=C+1,^TMP("IBPRO",$J,C)=I_"^"_D
  1. ;
  1. I C=0 W !!,"No Prosthetics to Choose From." Q
  1. ;
  1. W !!,"CHOOSE FROM:" F IBI=1:1:10 Q:'$D(^TMP("IBPRO",$J,IBI)) D WRP
  1. K ^TMP("IBPRO",$J)
  1. Q
  1. ;
  1. WRP S IBX=$P(^TMP("IBPRO",$J,IBI),"^",1,20),N=$P(IBX,U,1),P=$P(IBX,U,7) S P1=$S(+P:$P($G(^RMPR(661,P,0)),U,1),1:""),P2=$S(+P1:$P($G(^PRC(441,P1,0)),U,2),1:"")
  1. S DDT=$P(IBX,U,13),DDTO=$$FMTE^XLFDT(DDT,"2DZ"),IBARRAY(IBI)=N_U_P_U_DDT_U_P2_U_DDTO
  1. S TP=$P(IBX,U,4),TYPE=$S(TP="I":"INITIAL ISSUE",TP="R":"REPLACE",TP="S":"SPARE",TP="X":"REPAIR",1:"RENTAL")
  1. W !," ",IBI,?10,$E(P2,1,25),?40,TYPE,?58,"DELIVERED:",DDTO
  1. ;
  1. Q