146 lines
4.5 KiB
Mathematica
146 lines
4.5 KiB
Mathematica
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
|