Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBTRE5

IBTRE5.m

Go to the documentation of this file. 
  1. IBTRE5	;ALB/AAS - CLAIMS TRACKING EDIT PROVIDER ; 1-SEP-93
  1. 	;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
  1. 	;;Per VHA Directive 10-93-142, this routine should not be modified.
  1. 	;
  1. %	G ^IBTRE
  1. 	;
  1. EN(IBTRN)	; -- entry point for protocols
  1. 	;    must do own rebuild actions
  1. 	; -- Input - pointer to 356
  1. 	;
  1. 	N IBETYP,IBTRND,IBXY,IBCNT,IBDGPM
  1. 	D FULL^VALM1
  1. 	S VALMBCK=""
  1. 	S IBTRND=$G(^IBT(356,IBTRN,0)),IBDGPM=$P(IBTRND,"^",5)
  1. 	;
  1. 	S IBETYP=$$TRTP^IBTRE1(IBTRN)
  1. 	I IBETYP>2 W !!,"Clinical Information comes from the parent package." D PAUSE^VALM1 G ENQ
  1. 	;
  1. 	; -- outpatient provider
  1. 	I IBETYP=2 D  G ENQ
  1. 	.I $P(IBTRND,"^",4) D ASK^SDCO3(+$P(IBTRND,"^",4)) K SDCOQUIT
  1. 	.I '$P(IBTRND,"^",4) W !!,"Can not add provider to outpatient visits prior to Check-out.",! D PAUSE^VALM1
  1. 	.S VALMBCK="R"
  1. 	;
  1. 	; -- Inpatient provider
  1. 	I IBETYP=1 D
  1. 	.Q:'IBDGPM
  1. 	.; -- ask admitting provider
  1. 	.I '$O(^IBT(356.94,"ADG",IBDGPM,0)) D APRVD(IBTRN,IBETYP)
  1. 	.I $G(IBSEL)="^" Q
  1. 	.;
  1. 	.; -- edit other provider
  1. 	.D PRVD(IBTRN,IBETYP)
  1. 	.S VALMBCK="R"
  1. 	;
  1. ENQ	;
  1. 	Q
  1. APRVD(IBTRN,IBETYP)	; -- add admitting provider
  1. 	;
  1. 	N IBAPR,DA,DR,DIC,DIE,DD,DO,IOINHI,IOINORM
  1. 	S IBAPR=""
  1. 	;
  1. 	I IBETYP'=1!('IBDGPM) W !!,"You can only enter and admitting provider for an admission",! D PAUSE^VALM1 G APRVDQ
  1. 	;
  1. 	S X="IOINHI;IOINORM" D ENDR^%ZISS
  1. 	S IBAPR=$O(^IBT(356.94,"ADG",IBDGPM,0)) I IBAPR S IBDA=$O(^IBT(356.94,"ADG",IBDGPM,IBAPR,0))
  1. 	W !!,"--- ",IOINHI,"Admitting Physician",IOINORM," --- ",$S('IBAPR:"Unspecified",1:$P($G(^VA(200,+$P(IBAPR,"^",3),0)),"^"))
  1. 	I +IBAPR D EDT(IBDA,".03;") W !
  1. 	I '$O(^IBT(356.94,"ADG",IBDGPM,0)) D ADD(IBTRN,3)
  1. 	;
  1. 	W !
  1. APRVDQ	Q
  1. 	;
  1. PRVD(IBTRN,IBETYP)	; -- add/edit provider
  1. 	Q:'IBTRN
  1. 	I $G(IBETYP)'=1 Q
  1. 	N DA,DR,DIC,DIE
  1. 	I IBETYP'=1!('IBDGPM) W !!,"You can only enter a provider for an admission",! D PAUSE^VALM1 G PRVDQ
  1. 	;
  1. 	S X="IOINHI;IOINORM" D ENDR^%ZISS
  1. 	W !!,"--- ",IOINHI,"Provider",IOINORM," --- "
  1. 	S IBSEL="Add"
  1. 	D SET(IBTRN) I $D(IBXY) D LIST(.IBXY) S IBSEL=$$ASK^IBTRE4(IBCNT,"A")
  1. 	I IBSEL["^"!(IBSEL["Return") S:IBSEL["^" IBQUIT=1 G PRVDQ
  1. 	I IBSEL="Add" D ADD(IBTRN)
  1. 	D:IBSEL EDT(+$G(IBXY(+IBSEL)),".01;.03;.04")
  1. PRVDQ	Q
  1. 	;
  1. ADD(IBTRN,TYPE)	; -- Add a new provider
  1. 	;
  1. 	N DTOUT,DUTOU,X,Y,DIC
  1. 	S IBCNT=0
  1. 	I '$G(TYPE) S TYPE=""
  1. NXT	S DIC("A")=$S(TYPE=3:"Admitting Provider: ",IBCNT<1:"Select Provider: ",1:"Next Provider: ")
  1. 	S DIC("S")="I $D(^VA(200,""AK.PROVIDER"",$P(^(0),U,1),+Y))"
  1. 	S DIC="^VA(200,",DIC(0)="AEMQ",X=""
  1. 	W:$G(IBCNT) ! D ^DIC K DIC G ADDQ:Y<0
  1. 	S IBCNT=IBCNT+1
  1. 	S IBAPR=$$NEW(+Y,IBTRN,TYPE)
  1. 	I IBAPR,TYPE'=3 D EDT(IBAPR) G NXT
  1. ADDQ	I $D(DUOUT)!($D(DTOUT)) S IBSEL="^"
  1. 	Q
  1. 	;
  1. NEW(VA200,IBTRN,TYPE)	; -- file new entry
  1. 	;
  1. 	N DA,DD,DO,DIC,DIK,DINUM,DLAYGO,X,Y,I,J
  1. 	;
  1. 	; -- default date = episode date
  1. 	S X=$P($P(^IBT(356,IBTRN,0),"^",6),".")
  1. 	S (DIC,DIK)="^IBT(356.94,",DIC(0)="L",DLAYGO=356.94
  1. 	D FILE^DICN S IBAPR=+Y
  1. 	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)
  1. NEWQ	Q IBAPR
  1. 	;
  1. EDT(IBAPR,IBDR)	; -- edit entry
  1. 	;
  1. 	N DR,DIE,DA
  1. 	S DR=$G(IBDR) I DR="" S DR=".01;.03;.04"
  1. 	S DA=IBAPR,DIE="^IBT(356.94,"
  1. 	L +^IBT(356.94,IBAPR):5 I '$T D LOCKED^IBTRCD1 G EDTQ
  1. 	Q:'$G(^IBT(356.94,DA,0))
  1. 	D ^DIE
  1. 	L -^IBT(356.94,IBAPR)
  1. EDTQ	Q
  1. 	;
  1. SET(IBTRN)	; -- set array
  1. 	N IBDGPM,IBPRV
  1. 	S IBDGPM=$$DGPM^IBTRE3(IBTRN)
  1. 	S (IBPRV,IBCNT)=0
  1. 	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
  1. 	.S IBCNT=IBCNT+1
  1. 	.S IBXY(IBCNT)=IBDA
  1. SETQ	Q
  1. 	;
  1. LIST(IBXY)	;List Provider Array
  1. 	; Input  -- IBXY     Provider Array Subscripted by a Number
  1. 	; Output -- List Provider Array
  1. 	N I,IBXD,IBTNOD
  1. 	W !
  1. 	S I=0 F  S I=$O(IBXY(I)) Q:'I  D
  1. 	.S IBTNOD=$G(^IBT(356.94,+IBXY(I),0))
  1. 	.S IBXD=$P($G(^VA(200,$P(IBTNOD,"^",3),0)),"^")
  1. 	.W !?2,I,"  ",IBXD,?40,$$DAT1^IBOUTL($P($P(IBTNOD,"^",1),"."),2),?60,$$EXPAND^IBTRE(356.94,.04,$P(IBTNOD,"^",4))
  1. 	Q
  1. 	;
  1. DICS(Y)	; -- called by input transform and screen logic for type of provider
  1. 	N IBY
  1. 	S IBY=0
  1. 	I Y<3 S IBY=1 G DICSQ
  1. 	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
  1. DICSQ	Q IBY
  1. 	;
  1. DTCHK(DA,X)	; -- input transform for 356.94;.01.  date not before admission or after discharge
  1. 	N IBTRN,IBOK,IBCDT
  1. 	S IBOK=1
  1. 	G:'DA!($G(X)<1) DTCHKQ
  1. 	S IBTRN=+$O(^IBT(356,"AD",+$P(^IBT(356.94,DA,0),"^",2),0))
  1. 	G:'IBTRN DTCHKQ
  1. 	S IBCDT=$$CDT^IBTODD1(IBTRN)
  1. 	I X<$P(+IBCDT,".") S IBOK=0 G DTCHKQ ;before adm
  1. 	I $P(IBCDT,"^",2),X>$P(IBCDT,"^",2) S IBOK=0 G DTCHKQ ; after disch
  1. 	I X>$$FMADD^XLFDT(DT,7) S IBOK=0 G DTCHKQ
  1. 	;
  1. DTCHKQ	Q IBOK