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