IBTRKR2 ;ALB/AAS - ADD/TRACK SCHEDULED ADMISSION ;9-AUG-93
;;2.0;INTEGRATED BILLING;**43,62,214,312**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
% ;
EN ; -- add scheduled admissions to claims tracking file
N I,J,X,Y,IBTRKR,IBI,IBJ,DFN,IBDATA
N IBSWINFO S IBSWINFO=$$SWSTAT^IBBAPI() ;IB*2.0*312
S IBTRKR=$G(^IBE(350.9,1,6))
G:'$P(IBTRKR,"^",2) ENQ ; inpatient tracking off
S:'$G(IBTSBDT) IBTSBDT=$$FMADD^XLFDT(DT,-3)-.1
S:'$G(IBTSEDT) IBTSEDT=$$FMADD^XLFDT(DT,7)+.9
I IBTSBDT<+IBTRKR S IBTSBDT=+IBTRKR-.1 ; start date can't be before ct start date
S IBI=IBTSBDT-.0001
F S IBI=$O(^DGS(41.1,"C",IBI)) Q:'IBI!(IBI>IBTSEDT) S IBJ="" F S IBJ=$O(^DGS(41.1,"C",IBI,IBJ)) Q:'IBJ D
.;
.;Do NOT PROCESS on VistA if IBI/Sched DT>=Switch Eff Dt ;CCR-930
.I +IBSWINFO,(IBI+1)>$P(IBSWINFO,"^",2) Q ;IB*2.0*312
.;
.S IBDATA=$G(^DGS(41.1,IBJ,0))
.S DFN=+IBDATA
.Q:'DFN ; no patient
.Q:$P(IBDATA,"^",17) ; already admitted
.;
.S IBTRN=$O(^IBT(356,"ASCH",IBJ,0))
.I $P(IBDATA,"^",13) D:IBTRN INACTIVE^IBTRKRU(IBTRN) Q ; canceled
.;
.; - if not in ct add
.I 'IBTRN D Q
..I $P(IBTRKR,"^",2)=2 D SCH^IBTUTL2(DFN,IBI,IBJ) Q
..I $P(IBTRKR,"^",2)=1,$S('$$INSURED^IBCNS1(DFN,+IBI):0,1:$$PTCOV^IBCNSU3(DFN,+IBI,"INPATIENT")) D SCH^IBTUTL2(DFN,IBI,IBJ) Q
..D TRKR^IBCNRDV(DFN,IBI,IBJ,$P(IBDATA,"^",11))
..Q
.;
.; - if inactive re-activate
.I '$P(^IBT(356,+IBTRN,0),"^",20) D
..N X,Y,I,J,DA,DR,DIE,DIC
..S DA=IBTRN,DR=".2////1",DIE="^IBT(356," D ^DIE
.Q
;
ENQ K IBTSEDT,IBTSBDT
; add cleanup of ARDV
S X=0 F S X=$O(^IBT(356,"ARDV",X)) Q:X<1 S Y=0 F S Y=$O(^IBT(356,"ARDV",X,Y)) Q:Y<1 I Y<DT K ^IBT(356,"ARDV",X,Y)
Q
;
SCH(DGPMCA) ; -- is this admission movement a scheduled admission
; -- output scheduled admission pointer
;
N IBTSA S IBTSA=0
I '$G(DGPMCA) G SCHQ
S IBTSA=+$O(^DGS(41.1,"AMVT",DGPMCA,0))
SCHQ Q IBTSA
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBTRKR2 1972 printed Oct 16, 2024@18:29:15 Page 2
IBTRKR2 ;ALB/AAS - ADD/TRACK SCHEDULED ADMISSION ;9-AUG-93
+1 ;;2.0;INTEGRATED BILLING;**43,62,214,312**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
% ;
EN ; -- add scheduled admissions to claims tracking file
+1 NEW I,J,X,Y,IBTRKR,IBI,IBJ,DFN,IBDATA
+2 ;IB*2.0*312
NEW IBSWINFO
SET IBSWINFO=$$SWSTAT^IBBAPI()
+3 SET IBTRKR=$GET(^IBE(350.9,1,6))
+4 ; inpatient tracking off
if '$PIECE(IBTRKR,"^",2)
GOTO ENQ
+5 if '$GET(IBTSBDT)
SET IBTSBDT=$$FMADD^XLFDT(DT,-3)-.1
+6 if '$GET(IBTSEDT)
SET IBTSEDT=$$FMADD^XLFDT(DT,7)+.9
+7 ; start date can't be before ct start date
IF IBTSBDT<+IBTRKR
SET IBTSBDT=+IBTRKR-.1
+8 SET IBI=IBTSBDT-.0001
+9 FOR
SET IBI=$ORDER(^DGS(41.1,"C",IBI))
if 'IBI!(IBI>IBTSEDT)
QUIT
SET IBJ=""
FOR
SET IBJ=$ORDER(^DGS(41.1,"C",IBI,IBJ))
if 'IBJ
QUIT
Begin DoDot:1
+10 ;
+11 ;Do NOT PROCESS on VistA if IBI/Sched DT>=Switch Eff Dt ;CCR-930
+12 ;IB*2.0*312
IF +IBSWINFO
IF (IBI+1)>$PIECE(IBSWINFO,"^",2)
QUIT
+13 ;
+14 SET IBDATA=$GET(^DGS(41.1,IBJ,0))
+15 SET DFN=+IBDATA
+16 ; no patient
if 'DFN
QUIT
+17 ; already admitted
if $PIECE(IBDATA,"^",17)
QUIT
+18 ;
+19 SET IBTRN=$ORDER(^IBT(356,"ASCH",IBJ,0))
+20 ; canceled
IF $PIECE(IBDATA,"^",13)
if IBTRN
DO INACTIVE^IBTRKRU(IBTRN)
QUIT
+21 ;
+22 ; - if not in ct add
+23 IF 'IBTRN
Begin DoDot:2
+24 IF $PIECE(IBTRKR,"^",2)=2
DO SCH^IBTUTL2(DFN,IBI,IBJ)
QUIT
+25 IF $PIECE(IBTRKR,"^",2)=1
IF $SELECT('$$INSURED^IBCNS1(DFN,+IBI):0,1:$$PTCOV^IBCNSU3(DFN,+IBI,"INPATIENT"))
DO SCH^IBTUTL2(DFN,IBI,IBJ)
QUIT
+26 DO TRKR^IBCNRDV(DFN,IBI,IBJ,$PIECE(IBDATA,"^",11))
+27 QUIT
End DoDot:2
QUIT
+28 ;
+29 ; - if inactive re-activate
+30 IF '$PIECE(^IBT(356,+IBTRN,0),"^",20)
Begin DoDot:2
+31 NEW X,Y,I,J,DA,DR,DIE,DIC
+32 SET DA=IBTRN
SET DR=".2////1"
SET DIE="^IBT(356,"
DO ^DIE
End DoDot:2
+33 QUIT
End DoDot:1
+34 ;
ENQ KILL IBTSEDT,IBTSBDT
+1 ; add cleanup of ARDV
+2 SET X=0
FOR
SET X=$ORDER(^IBT(356,"ARDV",X))
if X<1
QUIT
SET Y=0
FOR
SET Y=$ORDER(^IBT(356,"ARDV",X,Y))
if Y<1
QUIT
IF Y<DT
KILL ^IBT(356,"ARDV",X,Y)
+3 QUIT
+4 ;
SCH(DGPMCA) ; -- is this admission movement a scheduled admission
+1 ; -- output scheduled admission pointer
+2 ;
+3 NEW IBTSA
SET IBTSA=0
+4 IF '$GET(DGPMCA)
GOTO SCHQ
+5 SET IBTSA=+$ORDER(^DGS(41.1,"AMVT",DGPMCA,0))
SCHQ QUIT IBTSA
