IBTRE5 ;ALB/AAS - CLAIMS TRACKING EDIT PROVIDER ; 1-SEP-93
;;Version 2.0 ; INTEGRATED BILLING ;**10,60**; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
% G ^IBTRE
;
EN(IBTRN) ; -- entry point for protocols
; must do own rebuild actions
; -- Input - pointer to 356
;
N IBETYP,IBTRND,IBXY,IBCNT,IBDGPM
D FULL^VALM1
S VALMBCK=""
S IBTRND=$G(^IBT(356,IBTRN,0)),IBDGPM=$P(IBTRND,"^",5)
;
S IBETYP=$$TRTP^IBTRE1(IBTRN)
I IBETYP>2 W !!,"Clinical Information comes from the parent package." D PAUSE^VALM1 G ENQ
;
; -- outpatient provider
I IBETYP=2 D G ENQ
.I $P(IBTRND,"^",4) D ASK^IBTUTL4(IBTRN,1)
.I '$P(IBTRND,"^",4) W !!,"Can not add provider to outpatient visits prior to Check-out.",! D PAUSE^VALM1
.S VALMBCK="R"
;
; -- Inpatient provider
I IBETYP=1 D
.Q:'IBDGPM
.; -- ask admitting provider
.I '$O(^IBT(356.94,"ADG",IBDGPM,0)) D APRVD(IBTRN,IBETYP)
.I $G(IBSEL)="^" Q
.;
.; -- edit other provider
.D PRVD(IBTRN,IBETYP)
.S VALMBCK="R"
;
ENQ ;
Q
APRVD(IBTRN,IBETYP) ; -- add admitting provider
;
N IBAPR,DA,DR,DIC,DIE,DD,DO,IOINHI,IOINORM
S IBAPR=""
;
I IBETYP'=1!('IBDGPM) W !!,"You can only enter and admitting provider for an admission",! D PAUSE^VALM1 G APRVDQ
;
S X="IOINHI;IOINORM" D ENDR^%ZISS
S IBAPR=$O(^IBT(356.94,"ADG",IBDGPM,0)) I IBAPR S IBDA=$O(^IBT(356.94,"ADG",IBDGPM,IBAPR,0))
W !!,"--- ",IOINHI,"Admitting Physician",IOINORM," --- ",$S('IBAPR:"Unspecified",1:$P($G(^VA(200,+$P(IBAPR,"^",3),0)),"^"))
I +IBAPR D EDT(IBDA,".03;") W !
I '$O(^IBT(356.94,"ADG",IBDGPM,0)) D ADD(IBTRN,3)
;
W !
APRVDQ Q
;
PRVD(IBTRN,IBETYP) ; -- add/edit provider
Q:'IBTRN
I $G(IBETYP)'=1 Q
N DA,DR,DIC,DIE
I IBETYP'=1!('IBDGPM) W !!,"You can only enter a provider for an admission",! D PAUSE^VALM1 G PRVDQ
;
S X="IOINHI;IOINORM" D ENDR^%ZISS
W !!,"--- ",IOINHI,"Provider",IOINORM," --- "
S IBSEL="Add"
D SET(IBTRN) I $D(IBXY) D LIST(.IBXY) S IBSEL=$$ASK^IBTRE4(IBCNT,"A")
I IBSEL["^"!(IBSEL["Return") S:IBSEL["^" IBQUIT=1 G PRVDQ
I IBSEL="Add" D ADD(IBTRN)
D:IBSEL EDT(+$G(IBXY(+IBSEL)),".01;.03;.04")
PRVDQ Q
;
ADD(IBTRN,TYPE) ; -- Add a new provider
;
N DTOUT,DUTOU,X,Y,DIC
S IBCNT=0
I '$G(TYPE) S TYPE=""
NXT S DIC("A")=$S(TYPE=3:"Admitting Provider: ",IBCNT<1:"Select Provider: ",1:"Next Provider: ")
S DIC("S")="I $D(^VA(200,""AK.PROVIDER"",$P(^(0),U,1),+Y))"
S DIC="^VA(200,",DIC(0)="AEMQ",X=""
W:$G(IBCNT) ! D ^DIC K DIC G ADDQ:Y<0
S IBCNT=IBCNT+1
S IBAPR=$$NEW(+Y,IBTRN,TYPE)
I IBAPR,TYPE'=3 D EDT(IBAPR) G NXT
ADDQ I $D(DUOUT)!($D(DTOUT)) S IBSEL="^"
Q
;
NEW(VA200,IBTRN,TYPE) ; -- file new entry
;
N DA,DD,DO,DIC,DIK,DINUM,DLAYGO,X,Y,I,J
;
; -- default date = episode date
S X=$P($P(^IBT(356,IBTRN,0),"^",6),".")
S (DIC,DIK)="^IBT(356.94,",DIC(0)="L",DLAYGO=356.94
D FILE^DICN S IBAPR=+Y
I IBAPR>0 L +^IBT(356.94,IBAPR) S $P(^IBT(356.94,IBAPR,0),"^",2,4)=$$DGPM^IBTRE3(IBTRN)_"^"_VA200_"^"_$G(TYPE),DA=IBAPR D IX1^DIK L -^IBT(356.94,IBAPR)
NEWQ Q IBAPR
;
EDT(IBAPR,IBDR) ; -- edit entry
;
N DR,DIE,DA,DIDEL
S DR=$G(IBDR),DIDEL=356.94 I DR="" S DR=".01;.03;.04"
S DA=IBAPR,DIE="^IBT(356.94,"
Q:'$G(^IBT(356.94,DA,0))
L +^IBT(356.94,IBAPR):5 I '$T D LOCKED^IBTRCD1 G EDTQ
D ^DIE
L -^IBT(356.94,IBAPR)
EDTQ Q
;
SET(IBTRN) ; -- set array
N IBDGPM,IBPRV
S IBDGPM=$$DGPM^IBTRE3(IBTRN)
S (IBPRV,IBCNT)=0
F S IBPRV=$O(^IBT(356.94,"ADGPM",IBDGPM,IBPRV)) Q:'IBPRV S IBDA=0 F S IBDA=$O(^IBT(356.94,"ADGPM",IBDGPM,IBPRV,IBDA)) Q:'IBDA D
.Q:'$D(^IBT(356.94,+IBDA,0))
.S IBCNT=IBCNT+1
.S IBXY(IBCNT)=IBDA
SETQ Q
;
LIST(IBXY) ;List Provider Array
; Input -- IBXY Provider Array Subscripted by a Number
; Output -- List Provider Array
N I,IBXD,IBTNOD
W !
S I=0 F S I=$O(IBXY(I)) Q:'I D
.S IBTNOD=$G(^IBT(356.94,+IBXY(I),0))
.S IBXD=$P($G(^VA(200,$P(IBTNOD,"^",3),0)),"^")
.W !?2,I," ",IBXD,?40,$$DAT1^IBOUTL($P($P(IBTNOD,"^",1),"."),2),?60,$$EXPAND^IBTRE(356.94,.04,$P(IBTNOD,"^",4))
Q
;
DICS(Y) ; -- called by input transform and screen logic for type of provider
N IBY
S IBY=0
I Y<3 S IBY=1 G DICSQ
I Y=3 I '$D(^IBT(356.94,"ATP",+$P($G(^IBT(356.94,DA,0)),U,2),3))!($O(^IBT(356.94,"ATP",+$P($G(^IBT(356.94,DA,0)),U,2),3,0))=DA) S IBY=1
DICSQ Q IBY
;
DTCHK(DA,X) ; -- input transform for 356.94;.01. date not before admission or after discharge
N IBTRN,IBOK,IBCDT
S IBOK=1
G:'DA!($G(X)<1) DTCHKQ
S IBTRN=+$O(^IBT(356,"AD",+$P(^IBT(356.94,DA,0),"^",2),0))
G:'IBTRN DTCHKQ
S IBCDT=$$CDT^IBTODD1(IBTRN)
I X<$P(+IBCDT,".") S IBOK=0 G DTCHKQ ;before adm
I $P(IBCDT,"^",2),X>$P(IBCDT,"^",2) S IBOK=0 G DTCHKQ ; after disch
I X>$$FMADD^XLFDT(DT,7) S IBOK=0 G DTCHKQ
;
DTCHKQ Q IBOK
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBTRE5 4783 printed Nov 22, 2024@17:37:54 Page 2
IBTRE5 ;ALB/AAS - CLAIMS TRACKING EDIT PROVIDER ; 1-SEP-93
+1 ;;Version 2.0 ; INTEGRATED BILLING ;**10,60**; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
% GOTO ^IBTRE
+1 ;
EN(IBTRN) ; -- entry point for protocols
+1 ; must do own rebuild actions
+2 ; -- Input - pointer to 356
+3 ;
+4 NEW IBETYP,IBTRND,IBXY,IBCNT,IBDGPM
+5 DO FULL^VALM1
+6 SET VALMBCK=""
+7 SET IBTRND=$GET(^IBT(356,IBTRN,0))
SET IBDGPM=$PIECE(IBTRND,"^",5)
+8 ;
+9 SET IBETYP=$$TRTP^IBTRE1(IBTRN)
+10 IF IBETYP>2
WRITE !!,"Clinical Information comes from the parent package."
DO PAUSE^VALM1
GOTO ENQ
+11 ;
+12 ; -- outpatient provider
+13 IF IBETYP=2
Begin DoDot:1
+14 IF $PIECE(IBTRND,"^",4)
DO ASK^IBTUTL4(IBTRN,1)
+15 IF '$PIECE(IBTRND,"^",4)
WRITE !!,"Can not add provider to outpatient visits prior to Check-out.",!
DO PAUSE^VALM1
+16 SET VALMBCK="R"
End DoDot:1
GOTO ENQ
+17 ;
+18 ; -- Inpatient provider
+19 IF IBETYP=1
Begin DoDot:1
+20 if 'IBDGPM
QUIT
+21 ; -- ask admitting provider
+22 IF '$ORDER(^IBT(356.94,"ADG",IBDGPM,0))
DO APRVD(IBTRN,IBETYP)
+23 IF $GET(IBSEL)="^"
QUIT
+24 ;
+25 ; -- edit other provider
+26 DO PRVD(IBTRN,IBETYP)
+27 SET VALMBCK="R"
End DoDot:1
+28 ;
ENQ ;
+1 QUIT
APRVD(IBTRN,IBETYP) ; -- add admitting provider
+1 ;
+2 NEW IBAPR,DA,DR,DIC,DIE,DD,DO,IOINHI,IOINORM
+3 SET IBAPR=""
+4 ;
+5 IF IBETYP'=1!('IBDGPM)
WRITE !!,"You can only enter and admitting provider for an admission",!
DO PAUSE^VALM1
GOTO APRVDQ
+6 ;
+7 SET X="IOINHI;IOINORM"
DO ENDR^%ZISS
+8 SET IBAPR=$ORDER(^IBT(356.94,"ADG",IBDGPM,0))
IF IBAPR
SET IBDA=$ORDER(^IBT(356.94,"ADG",IBDGPM,IBAPR,0))
+9 WRITE !!,"--- ",IOINHI,"Admitting Physician",IOINORM," --- ",$SELECT('IBAPR:"Unspecified",1:$PIECE($GET(^VA(200,+$PIECE(IBAPR,"^",3),0)),"^"))
+10 IF +IBAPR
DO EDT(IBDA,".03;")
WRITE !
+11 IF '$ORDER(^IBT(356.94,"ADG",IBDGPM,0))
DO ADD(IBTRN,3)
+12 ;
+13 WRITE !
APRVDQ QUIT
+1 ;
PRVD(IBTRN,IBETYP) ; -- add/edit provider
+1 if 'IBTRN
QUIT
+2 IF $GET(IBETYP)'=1
QUIT
+3 NEW DA,DR,DIC,DIE
+4 IF IBETYP'=1!('IBDGPM)
WRITE !!,"You can only enter a provider for an admission",!
DO PAUSE^VALM1
GOTO PRVDQ
+5 ;
+6 SET X="IOINHI;IOINORM"
DO ENDR^%ZISS
+7 WRITE !!,"--- ",IOINHI,"Provider",IOINORM," --- "
+8 SET IBSEL="Add"
+9 DO SET(IBTRN)
IF $DATA(IBXY)
DO LIST(.IBXY)
SET IBSEL=$$ASK^IBTRE4(IBCNT,"A")
+10 IF IBSEL["^"!(IBSEL["Return")
if IBSEL["^"
SET IBQUIT=1
GOTO PRVDQ
+11 IF IBSEL="Add"
DO ADD(IBTRN)
+12 if IBSEL
DO EDT(+$GET(IBXY(+IBSEL)),".01;.03;.04")
PRVDQ QUIT
+1 ;
ADD(IBTRN,TYPE) ; -- Add a new provider
+1 ;
+2 NEW DTOUT,DUTOU,X,Y,DIC
+3 SET IBCNT=0
+4 IF '$GET(TYPE)
SET TYPE=""
NXT SET DIC("A")=$SELECT(TYPE=3:"Admitting Provider: ",IBCNT<1:"Select Provider: ",1:"Next Provider: ")
+1 SET DIC("S")="I $D(^VA(200,""AK.PROVIDER"",$P(^(0),U,1),+Y))"
+2 SET DIC="^VA(200,"
SET DIC(0)="AEMQ"
SET X=""
+3 if $GET(IBCNT)
WRITE !
DO ^DIC
KILL DIC
if Y<0
GOTO ADDQ
+4 SET IBCNT=IBCNT+1
+5 SET IBAPR=$$NEW(+Y,IBTRN,TYPE)
+6 IF IBAPR
IF TYPE'=3
DO EDT(IBAPR)
GOTO NXT
ADDQ IF $DATA(DUOUT)!($DATA(DTOUT))
SET IBSEL="^"
+1 QUIT
+2 ;
NEW(VA200,IBTRN,TYPE) ; -- file new entry
+1 ;
+2 NEW DA,DD,DO,DIC,DIK,DINUM,DLAYGO,X,Y,I,J
+3 ;
+4 ; -- default date = episode date
+5 SET X=$PIECE($PIECE(^IBT(356,IBTRN,0),"^",6),".")
+6 SET (DIC,DIK)="^IBT(356.94,"
SET DIC(0)="L"
SET DLAYGO=356.94
+7 DO FILE^DICN
SET IBAPR=+Y
+8 IF IBAPR>0
LOCK +^IBT(356.94,IBAPR)
SET $PIECE(^IBT(356.94,IBAPR,0),"^",2,4)=$$DGPM^IBTRE3(IBTRN)_"^"_VA200_"^"_$GET(TYPE)
SET DA=IBAPR
DO IX1^DIK
LOCK -^IBT(356.94,IBAPR)
NEWQ QUIT IBAPR
+1 ;
EDT(IBAPR,IBDR) ; -- edit entry
+1 ;
+2 NEW DR,DIE,DA,DIDEL
+3 SET DR=$GET(IBDR)
SET DIDEL=356.94
IF DR=""
SET DR=".01;.03;.04"
+4 SET DA=IBAPR
SET DIE="^IBT(356.94,"
+5 if '$GET(^IBT(356.94,DA,0))
QUIT
+6 LOCK +^IBT(356.94,IBAPR):5
IF '$TEST
DO LOCKED^IBTRCD1
GOTO EDTQ
+7 DO ^DIE
+8 LOCK -^IBT(356.94,IBAPR)
EDTQ QUIT
+1 ;
SET(IBTRN) ; -- set array
+1 NEW IBDGPM,IBPRV
+2 SET IBDGPM=$$DGPM^IBTRE3(IBTRN)
+3 SET (IBPRV,IBCNT)=0
+4 FOR
SET IBPRV=$ORDER(^IBT(356.94,"ADGPM",IBDGPM,IBPRV))
if 'IBPRV
QUIT
SET IBDA=0
FOR
SET IBDA=$ORDER(^IBT(356.94,"ADGPM",IBDGPM,IBPRV,IBDA))
if 'IBDA
QUIT
Begin DoDot:1
+5 if '$DATA(^IBT(356.94,+IBDA,0))
QUIT
+6 SET IBCNT=IBCNT+1
+7 SET IBXY(IBCNT)=IBDA
End DoDot:1
SETQ QUIT
+1 ;
LIST(IBXY) ;List Provider Array
+1 ; Input -- IBXY Provider Array Subscripted by a Number
+2 ; Output -- List Provider Array
+3 NEW I,IBXD,IBTNOD
+4 WRITE !
+5 SET I=0
FOR
SET I=$ORDER(IBXY(I))
if 'I
QUIT
Begin DoDot:1
+6 SET IBTNOD=$GET(^IBT(356.94,+IBXY(I),0))
+7 SET IBXD=$PIECE($GET(^VA(200,$PIECE(IBTNOD,"^",3),0)),"^")
+8 WRITE !?2,I," ",IBXD,?40,$$DAT1^IBOUTL($PIECE($PIECE(IBTNOD,"^",1),"."),2),?60,$$EXPAND^IBTRE(356.94,.04,$PIECE(IBTNOD,"^",4))
End DoDot:1
+9 QUIT
+10 ;
DICS(Y) ; -- called by input transform and screen logic for type of provider
+1 NEW IBY
+2 SET IBY=0
+3 IF Y<3
SET IBY=1
GOTO DICSQ
+4 IF Y=3
IF '$DATA(^IBT(356.94,"ATP",+$PIECE($GET(^IBT(356.94,DA,0)),U,2),3))!($ORDER(^IBT(356.94,"ATP",+$PIECE($GET(^IBT(356.94,DA,0)),U,2),3,0))=DA)
SET IBY=1
DICSQ QUIT IBY
+1 ;
DTCHK(DA,X) ; -- input transform for 356.94;.01. date not before admission or after discharge
+1 NEW IBTRN,IBOK,IBCDT
+2 SET IBOK=1
+3 if 'DA!($GET(X)<1)
GOTO DTCHKQ
+4 SET IBTRN=+$ORDER(^IBT(356,"AD",+$PIECE(^IBT(356.94,DA,0),"^",2),0))
+5 if 'IBTRN
GOTO DTCHKQ
+6 SET IBCDT=$$CDT^IBTODD1(IBTRN)
+7 ;before adm
IF X<$PIECE(+IBCDT,".")
SET IBOK=0
GOTO DTCHKQ
+8 ; after disch
IF $PIECE(IBCDT,"^",2)
IF X>$PIECE(IBCDT,"^",2)
SET IBOK=0
GOTO DTCHKQ
+9 IF X>$$FMADD^XLFDT(DT,7)
SET IBOK=0
GOTO DTCHKQ
+10 ;
DTCHKQ QUIT IBOK
