IBTRPR01 ;ALB/AAS - CLAIMS TRACKING - PENDING WORK SCREEN ; 22-JUL-1993
;;2.0;INTEGRATED BILLING;**23,33,91**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
% G ^IBTRPR
;
;
1 S (X,ENTRY)="",TYPE="Hosp Reviews",FILE=356.1,IBDV=1
S IBI=IBTPBDT-.0001 F S IBI=$O(^IBT(356.1,"APEND",IBI)) Q:'IBI!(IBI>(IBTPEDT+.9)) S IBJ="" F S IBJ=$O(^IBT(356.1,"APEND",IBI,IBJ)) Q:'IBJ D
.S (ENTRY,IBTRV)=IBJ
.I IBTPRT'="B" D Q:IBQUIT
..S IBQUIT=1
..S IBTX=$P($G(^IBE(356.11,+$P($G(^IBT(356.1,+IBTRV,0)),"^",22),0)),"^",2)
..I IBTPRT="C",IBTX>29 S IBQUIT=0 Q
..I IBTPRT="A",IBTX<30 S IBQUIT=0
.S IBDATE=IBI
.S IBTRN=$P($G(^IBT(356.1,+IBTRV,0)),"^",2)
.I $P($G(^IBT(356,+IBTRN,0)),"^",20)'=1 Q
.S DFN=$P($G(^IBT(356,+IBTRN,0)),"^",2)
.I $G(IBTOPW) S IBDV=$$DIV(IBTRN)
.S IBWARD=$P($G(^DPT(DFN,.1)),"^")
.S IBSTATUS=$P($G(^IBT(356.1,IBTRV,0)),"^",21)
.S IBNEXT=$S(IBSTATUS=10:"ADD NEXT REV.",1:"EDIT REVIEW")
.S IBSTATUS=$$EXPAND^IBTRE(356.1,.21,IBSTATUS)
.S IBREV=$P($G(^IBT(356.1,IBTRV,0)),"^",22)
.S IBASSIGN=$P($G(^VA(200,+$P($G(^IBT(356,IBTRN,1)),"^",5),0)),"^")
.I IBTWHO'="A" D Q:IBQUIT
..S IBQUIT=1
..I IBTWHO="Y",DUZ=$P($G(^IBT(356,+IBTRN,1)),"^",5) S IBQUIT=0 Q
..I IBTWHO="U",IBASSIGN=""!(DUZ=$P($G(^IBT(356,+IBTRN,1)),"^",5)) S IBQUIT=0
.I IBASSIGN="" S IBASSIGN="Unassigned"
.D TEMP
.Q
S IBQUIT=0
Q
;
2 S (X,ENTRY)="",TYPE="Ins. Reviews",FILE=356.2,IBDV=1
S IBI=IBTPBDT-.0001 F S IBI=$O(^IBT(356.2,"APEND",IBI)) Q:'IBI!(IBI>(IBTPEDT+.9)) S IBJ="" F S IBJ=$O(^IBT(356.2,"APEND",IBI,IBJ)) Q:'IBJ D
.S (ENTRY,IBTRC)=IBJ
.I IBTPRT'="B" D Q:IBQUIT
..S IBQUIT=1
..S IBTX=$P($G(^IBE(356.11,+$P($G(^IBT(356.2,+IBTRC,0)),"^",4),0)),"^",2)
..I IBTPRT="C",IBTX>29 S IBQUIT=0
..I IBTPRT="A",IBTX<30 S IBQUIT=0
.S IBDATE=IBI
.S IBTRN=$P($G(^IBT(356.2,+IBTRC,0)),"^",2)
.I $P($G(^IBT(356,+IBTRN,0)),"^",20)'=1 Q
.S DFN=$P($G(^IBT(356,+IBTRN,0)),"^",2)
.I $G(IBTOPW) S IBDV=$$DIV(IBTRN)
.S IBREV=$P($G(^IBT(356.2,IBTRC,0)),"^",4)
.S IBWARD=$P($G(^DPT(DFN,.1)),"^")
.S IBSTATUS=$P($G(^IBT(356.2,IBTRC,0)),"^",19)
.S IBNEXT=$S(IBSTATUS=10:"ADD NEXT REV.",1:"EDIT REVIEW")
.S IBSTATUS=$$EXPAND^IBTRE(356.2,.19,IBSTATUS)
.S IBASSIGN=$P($G(^VA(200,+$P($G(^IBT(356,IBTRN,1)),"^",6),0)),"^")
.I IBTWHO'="A" D Q:IBQUIT
..S IBQUIT=1
..I IBTWHO="Y",DUZ=$P($G(^IBT(356,+IBTRN,1)),"^",6) S IBQUIT=0 Q
..I IBTWHO="U",IBASSIGN=""!(DUZ=$P($G(^IBT(356,+IBTRN,1)),"^",6)) S IBQUIT=0
.I IBASSIGN="" S IBASSIGN="Unassigned"
.D TEMP
.Q
S IBQUIT=0
Q
;
;
TEMP ; -- build temp array
N IBTSORT
S IBTSORT=$S(IBSORT="W":IBWARD,IBSORT="P":$P($G(^DPT(DFN,0)),"^"),IBSORT="T":$P($G(^IBE(356.11,+IBREV,0)),"^"),IBSORT="D":IBDATE,IBSORT="A":IBASSIGN,1:"ZZ!@#$%^&*()_+")
I IBTSORT="" S IBTSORT="ZZ!@#$%^&*()_+"
S ^TMP("IBSRT",$J,$E(IBDV,1,20),TYPE,$E(IBTSORT,1,20),$E($P(^DPT(DFN,0),"^"),1,20),IBTRN,ENTRY)=IBTRN_"^"_ENTRY_"^"_IBDATE_"^"_DFN_"^"_IBWARD_"^"_IBSTATUS_"^"_IBREV_"^"_FILE_"^"_IBASSIGN_"^"_IBNEXT
S ^TMP("IBSRT1",$J,DFN,TYPE)=""
Q
;
DIV(IBTRN) ; -- comput division of a tracking entry
; -- input ien to 356
; -- output name (.01) of entry in 40.8 or unknown
N IBDV,DFN S IBDV=""
I $G(^IBT(356,+$G(IBTRN),0))="" G DIVQ
S DFN=$P(^IBT(356,+IBTRN,0),"^",2)
I $P($G(^IBT(356,+IBTRN,0)),"^",5) D G DIVQ
.S IBDV=+$P($G(^DIC(42,+$P($G(^DGPM(+$P($G(^IBT(356,+IBTRN,0)),"^",5),0)),"^",6),0)),"^",11) ;default is division of admission movement
.I $G(^DPT(DFN,.1))'="",+$P(^IBT(356,+IBTRN,0),"^",5)=+$G(^DPT(DFN,.105)) S IBDV=+$P($G(^DIC(42,+$O(^DIC(42,"B",$P($G(^DPT(DFN,.1)),"^"),0)),0)),"^",11) ;if current adm=adm from movement compute current div
;
I $P($G(^IBT(356,+IBTRN,0)),"^",4) D G DIVQ
.S IBDV=+$$SCE^IBSDU(+$P($G(^IBT(356,+IBTRN,0)),"^",4),11)
;
I $P($G(^IBT(356,+IBTRN,0)),"^",32),'$P(^IBT(356,+IBTRN,0),"^",5) D
.S IBDV=+$P($G(^DGS(41.1,+$P(^IBT(356,+IBTRN,0),"^",32),0)),"^",12)
.I 'IBDV S IBDV=+$P($G(^DIC(42,+$P($G(^DGS(41.1,+$P(^IBT(356,+IBTRN,0),"^",32),0)),"^",8),0)),"^",11)
;
DIVQ I IBDV S IBDV=$P($G(^DG(40.8,+IBDV,0)),"^")
E S IBDV="UNKNOWN"
Q IBDV
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBTRPR01 4147 printed Dec 13, 2024@02:28:50 Page 2
IBTRPR01 ;ALB/AAS - CLAIMS TRACKING - PENDING WORK SCREEN ; 22-JUL-1993
+1 ;;2.0;INTEGRATED BILLING;**23,33,91**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
% GOTO ^IBTRPR
+1 ;
+2 ;
1 SET (X,ENTRY)=""
SET TYPE="Hosp Reviews"
SET FILE=356.1
SET IBDV=1
+1 SET IBI=IBTPBDT-.0001
FOR
SET IBI=$ORDER(^IBT(356.1,"APEND",IBI))
if 'IBI!(IBI>(IBTPEDT+.9))
QUIT
SET IBJ=""
FOR
SET IBJ=$ORDER(^IBT(356.1,"APEND",IBI,IBJ))
if 'IBJ
QUIT
Begin DoDot:1
+2 SET (ENTRY,IBTRV)=IBJ
+3 IF IBTPRT'="B"
Begin DoDot:2
+4 SET IBQUIT=1
+5 SET IBTX=$PIECE($GET(^IBE(356.11,+$PIECE($GET(^IBT(356.1,+IBTRV,0)),"^",22),0)),"^",2)
+6 IF IBTPRT="C"
IF IBTX>29
SET IBQUIT=0
QUIT
+7 IF IBTPRT="A"
IF IBTX<30
SET IBQUIT=0
End DoDot:2
if IBQUIT
QUIT
+8 SET IBDATE=IBI
+9 SET IBTRN=$PIECE($GET(^IBT(356.1,+IBTRV,0)),"^",2)
+10 IF $PIECE($GET(^IBT(356,+IBTRN,0)),"^",20)'=1
QUIT
+11 SET DFN=$PIECE($GET(^IBT(356,+IBTRN,0)),"^",2)
+12 IF $GET(IBTOPW)
SET IBDV=$$DIV(IBTRN)
+13 SET IBWARD=$PIECE($GET(^DPT(DFN,.1)),"^")
+14 SET IBSTATUS=$PIECE($GET(^IBT(356.1,IBTRV,0)),"^",21)
+15 SET IBNEXT=$SELECT(IBSTATUS=10:"ADD NEXT REV.",1:"EDIT REVIEW")
+16 SET IBSTATUS=$$EXPAND^IBTRE(356.1,.21,IBSTATUS)
+17 SET IBREV=$PIECE($GET(^IBT(356.1,IBTRV,0)),"^",22)
+18 SET IBASSIGN=$PIECE($GET(^VA(200,+$PIECE($GET(^IBT(356,IBTRN,1)),"^",5),0)),"^")
+19 IF IBTWHO'="A"
Begin DoDot:2
+20 SET IBQUIT=1
+21 IF IBTWHO="Y"
IF DUZ=$PIECE($GET(^IBT(356,+IBTRN,1)),"^",5)
SET IBQUIT=0
QUIT
+22 IF IBTWHO="U"
IF IBASSIGN=""!(DUZ=$PIECE($GET(^IBT(356,+IBTRN,1)),"^",5))
SET IBQUIT=0
End DoDot:2
if IBQUIT
QUIT
+23 IF IBASSIGN=""
SET IBASSIGN="Unassigned"
+24 DO TEMP
+25 QUIT
End DoDot:1
+26 SET IBQUIT=0
+27 QUIT
+28 ;
2 SET (X,ENTRY)=""
SET TYPE="Ins. Reviews"
SET FILE=356.2
SET IBDV=1
+1 SET IBI=IBTPBDT-.0001
FOR
SET IBI=$ORDER(^IBT(356.2,"APEND",IBI))
if 'IBI!(IBI>(IBTPEDT+.9))
QUIT
SET IBJ=""
FOR
SET IBJ=$ORDER(^IBT(356.2,"APEND",IBI,IBJ))
if 'IBJ
QUIT
Begin DoDot:1
+2 SET (ENTRY,IBTRC)=IBJ
+3 IF IBTPRT'="B"
Begin DoDot:2
+4 SET IBQUIT=1
+5 SET IBTX=$PIECE($GET(^IBE(356.11,+$PIECE($GET(^IBT(356.2,+IBTRC,0)),"^",4),0)),"^",2)
+6 IF IBTPRT="C"
IF IBTX>29
SET IBQUIT=0
+7 IF IBTPRT="A"
IF IBTX<30
SET IBQUIT=0
End DoDot:2
if IBQUIT
QUIT
+8 SET IBDATE=IBI
+9 SET IBTRN=$PIECE($GET(^IBT(356.2,+IBTRC,0)),"^",2)
+10 IF $PIECE($GET(^IBT(356,+IBTRN,0)),"^",20)'=1
QUIT
+11 SET DFN=$PIECE($GET(^IBT(356,+IBTRN,0)),"^",2)
+12 IF $GET(IBTOPW)
SET IBDV=$$DIV(IBTRN)
+13 SET IBREV=$PIECE($GET(^IBT(356.2,IBTRC,0)),"^",4)
+14 SET IBWARD=$PIECE($GET(^DPT(DFN,.1)),"^")
+15 SET IBSTATUS=$PIECE($GET(^IBT(356.2,IBTRC,0)),"^",19)
+16 SET IBNEXT=$SELECT(IBSTATUS=10:"ADD NEXT REV.",1:"EDIT REVIEW")
+17 SET IBSTATUS=$$EXPAND^IBTRE(356.2,.19,IBSTATUS)
+18 SET IBASSIGN=$PIECE($GET(^VA(200,+$PIECE($GET(^IBT(356,IBTRN,1)),"^",6),0)),"^")
+19 IF IBTWHO'="A"
Begin DoDot:2
+20 SET IBQUIT=1
+21 IF IBTWHO="Y"
IF DUZ=$PIECE($GET(^IBT(356,+IBTRN,1)),"^",6)
SET IBQUIT=0
QUIT
+22 IF IBTWHO="U"
IF IBASSIGN=""!(DUZ=$PIECE($GET(^IBT(356,+IBTRN,1)),"^",6))
SET IBQUIT=0
End DoDot:2
if IBQUIT
QUIT
+23 IF IBASSIGN=""
SET IBASSIGN="Unassigned"
+24 DO TEMP
+25 QUIT
End DoDot:1
+26 SET IBQUIT=0
+27 QUIT
+28 ;
+29 ;
TEMP ; -- build temp array
+1 NEW IBTSORT
+2 SET IBTSORT=$SELECT(IBSORT="W":IBWARD,IBSORT="P":$PIECE($GET(^DPT(DFN,0)),"^"),IBSORT="T":$PIECE($GET(^IBE(356.11,+IBREV,0)),"^"),IBSORT="D":IBDATE,IBSORT="A":IBASSIGN,1:"ZZ!@#$%^&*()_+")
+3 IF IBTSORT=""
SET IBTSORT="ZZ!@#$%^&*()_+"
+4 SET ^TMP("IBSRT",$JOB,$EXTRACT(IBDV,1,20),TYPE,$EXTRACT(IBTSORT,1,20),$EXTRACT($PIECE(^DPT(DFN,0),"^"),1,20),IBTRN,ENTRY)=IBTRN_"^"_ENTRY_"^"_IBDATE_"^"_DFN_"^"_IBWARD_"^"_IBSTATUS_"^"_IBREV_"^"_FILE_"^"_IBASSIGN_"^"_IBNEXT
+5 SET ^TMP("IBSRT1",$JOB,DFN,TYPE)=""
+6 QUIT
+7 ;
DIV(IBTRN) ; -- comput division of a tracking entry
+1 ; -- input ien to 356
+2 ; -- output name (.01) of entry in 40.8 or unknown
+3 NEW IBDV,DFN
SET IBDV=""
+4 IF $GET(^IBT(356,+$GET(IBTRN),0))=""
GOTO DIVQ
+5 SET DFN=$PIECE(^IBT(356,+IBTRN,0),"^",2)
+6 IF $PIECE($GET(^IBT(356,+IBTRN,0)),"^",5)
Begin DoDot:1
+7 ;default is division of admission movement
SET IBDV=+$PIECE($GET(^DIC(42,+$PIECE($GET(^DGPM(+$PIECE($GET(^IBT(356,+IBTRN,0)),"^",5),0)),"^",6),0)),"^",11)
+8 ;if current adm=adm from movement compute current div
IF $GET(^DPT(DFN,.1))'=""
IF +$PIECE(^IBT(356,+IBTRN,0),"^",5)=+$GET(^DPT(DFN,.105))
SET IBDV=+$PIECE($GET(^DIC(42,+$ORDER(^DIC(42,"B",$PIECE($GET(^DPT(DFN,.1)),"^"),0)),0)),"^",11)
End DoDot:1
GOTO DIVQ
+9 ;
+10 IF $PIECE($GET(^IBT(356,+IBTRN,0)),"^",4)
Begin DoDot:1
+11 SET IBDV=+$$SCE^IBSDU(+$PIECE($GET(^IBT(356,+IBTRN,0)),"^",4),11)
End DoDot:1
GOTO DIVQ
+12 ;
+13 IF $PIECE($GET(^IBT(356,+IBTRN,0)),"^",32)
IF '$PIECE(^IBT(356,+IBTRN,0),"^",5)
Begin DoDot:1
+14 SET IBDV=+$PIECE($GET(^DGS(41.1,+$PIECE(^IBT(356,+IBTRN,0),"^",32),0)),"^",12)
+15 IF 'IBDV
SET IBDV=+$PIECE($GET(^DIC(42,+$PIECE($GET(^DGS(41.1,+$PIECE(^IBT(356,+IBTRN,0),"^",32),0)),"^",8),0)),"^",11)
End DoDot:1
+16 ;
DIVQ IF IBDV
SET IBDV=$PIECE($GET(^DG(40.8,+IBDV,0)),"^")
+1 IF '$TEST
SET IBDV="UNKNOWN"
+2 QUIT IBDV
