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

IBTRE3.m

Go to the documentation of this file. 
  1. IBTRE3	;ALB/AAS - CLAIMS TRACKING EDIT DIAGNOSIS ; 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 - point 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 diagnosis
  1. 	I IBETYP=2 D  G ENQ
  1. 	.I $P(IBTRND,"^",4) D ASK^SDCO4(+$P(IBTRND,"^",4)) K SDCOQUIT
  1. 	.I '$P(IBTRND,"^",4) W !!,"Can not add diagnosis to outpatient visits prior to Check-out.",! D PAUSE^VALM1
  1. 	.S VALMBCK="R"
  1. 	;
  1. 	; -- Inpatient diagnosis
  1. 	I IBETYP=1 D
  1. 	.Q:'IBDGPM
  1. 	.;
  1. 	.; -- ask admitting diagnosis if not already there
  1. 	.I '$O(^IBT(356.9,"ADG",+IBDGPM,0)) D ADIAG(IBTRN,IBETYP)
  1. 	.I $G(IBSEL)="^" Q
  1. 	.;
  1. 	.; -- edit other diagnosis
  1. 	.D DIAG(IBTRN,IBETYP)
  1. 	.S VALMBCK="R"
  1. 	;
  1. ENQ	;
  1. 	Q
  1. ADIAG(IBTRN,IBETYP)	; -- add admitting diagnosis
  1. 	;
  1. 	N IBADG,DA,DR,DIC,DIE,DD,DO,IOINHI,IOINORM
  1. 	S IBADG=""
  1. 	;
  1. 	;S IBDGPM=$P(^IBT(356,+IBTRN,0),"^",5)
  1. 	I IBETYP'=1!('IBDGPM) W !!,"You can only enter and admitting diagnosis for an admission",! D PAUSE^VALM1 G ADGQ
  1. 	;
  1. 	S X="IOINHI;IOINORM" D ENDR^%ZISS
  1. 	S IBADG=$O(^IBT(356.9,"ADG",IBDGPM,0)) I IBADG S IBDA=$O(^IBT(356.9,"ADG",IBDGPM,IBADG,0))
  1. 	W !!,"--- ",IOINHI,"Admitting Diagnosis",IOINORM," --- ",$S('IBADG:"Unspecified",1:$P($G(^ICD9(+IBADG,0)),"^")_" -"_$P(^(0),"^",3))
  1. 	I +IBADG D EDT(IBDA,".01;") W !
  1. 	I '$O(^IBT(356.9,"ADG",+IBDGPM,0)) D ADD(IBTRN,3)
  1. 	;
  1. 	W !
  1. ADGQ	Q
  1. 	;
  1. DIAG(IBTRN,IBETYP)	; -- add/edit diagnosis
  1. 	Q:'IBTRN
  1. 	I $G(IBETYP)'=1 Q
  1. 	N DA,DR,DIC,DIE
  1. 	S IBDGPM=$P(^IBT(356,+IBTRN,0),"^",5)
  1. 	I IBETYP'=1!('IBDGPM) W !!,"You can only enter a diagnosis for an admission",! D PAUSE^VALM1 G ADGQ
  1. 	;
  1. 	S X="IOINHI;IOINORM" D ENDR^%ZISS
  1. 	W !!,"--- ",IOINHI,"Diagnosis",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 DIAGQ
  1. 	I IBSEL="Add" D ADD(IBTRN)
  1. 	D:IBSEL EDT(+$G(IBXY(+IBSEL)),".01;.03;.04")
  1. DIAGQ	Q
  1. 	;
  1. ADD(IBTRN,TYPE)	; -- Add a new diagnosis
  1. 	;
  1. 	N DTOUT,DUOUT,X,Y,DIC
  1. 	S IBCNT=0
  1. 	I '$G(TYPE) S TYPE=""
  1. NXT	S DIC("A")=$S(TYPE=3:"Admitting Diagnosis: ",IBCNT<1:"Select Diagnosis: ",1:"Next Diagnosis: ")
  1. 	S DIC("S")="I '$P(^(0),U,9)"
  1. 	S DIC="^ICD9(",DIC(0)="AEMQ",X=""
  1. 	W:$G(IBCNT) ! D ^DIC K DIC G ADDQ:Y<0
  1. 	I $D(^IBT(356.9,"ADGPM",$$DGPM(IBTRN),+Y)) W !!,*7,$P(Y,"^",2)," is already a diagnosis.",! G NXT
  1. 	S IBCNT=IBCNT+1
  1. 	S IBADG=$$NEW(+Y,IBTRN,TYPE)
  1. 	I IBADG,TYPE'=3 D EDT(IBADG) G NXT
  1. ADDQ	I $D(DTOUT)!($D(DUOUT)) S IBSEL="^"
  1. 	Q
  1. 	;
  1. DGPM(IBTRN)	; -- return admission pointer
  1. 	Q $P(^IBT(356,+IBTRN,0),"^",5)
  1. 	;
  1. NEW(ICDI,IBTRN,TYPE)	; -- file new entry
  1. 	;
  1. 	N DA,DD,DO,DIC,DIK,DINUM,DLAYGO,X,Y,I,J
  1. 	S X=ICDI,(DIC,DIK)="^IBT(356.9,",DIC(0)="L",DLAYGO=356.9
  1. 	D FILE^DICN S IBADG=+Y
  1. 	I IBADG>0 L +^IBT(356.9,IBADG) S $P(^IBT(356.9,IBADG,0),"^",2,4)=$$DGPM(IBTRN)_"^"_$P($P(^IBT(356,IBTRN,0),"^",6),".")_"^"_$G(TYPE),DA=IBADG D IX1^DIK L -^IBT(356.9,IBADG)
  1. NEWQ	Q IBADG
  1. 	;
  1. EDT(IBADG,IBDR)	; -- edit entry
  1. 	;
  1. 	N DR,DIE,DA
  1. 	S DR=$G(IBDR) I DR="" S DR=".03;.04"
  1. 	S DA=IBADG,DIE="^IBT(356.9,"
  1. 	L +^IBT(356.9,+IBADG):5 I '$T D LOCKED^IBTRCD1 G EDTQ
  1. 	Q:'$G(^IBT(356.9,DA,0))
  1. 	D ^DIE
  1. 	L -^IBT(356.9,+IBADG)
  1. EDTQ	Q
  1. 	;
  1. SET(IBTRN)	; -- set array
  1. 	N IBDGPM,IBICD
  1. 	S IBDGPM=$$DGPM(IBTRN)
  1. 	S (IBICD,IBCNT)=0
  1. 	F  S IBICD=$O(^IBT(356.9,"ADGPM",IBDGPM,IBICD)) Q:'IBICD  S IBDA=$O(^(IBICD,0)) D
  1. 	.S IBCNT=IBCNT+1
  1. 	.S IBXY(IBCNT)=IBDA_"^"_IBICD
  1. SETQ	Q
  1. 	;
  1. LIST(IBXY)	;List Diagnosis Array
  1. 	; Input  -- IBXY     Diagnosis Array Subscripted by a Number
  1. 	; Output -- List Diagnosis Array
  1. 	N I,IBXD
  1. 	W !
  1. 	S I=0 F  S I=$O(IBXY(I)) Q:'I  S IBXD=$G(^ICD9(+$P(IBXY(I),"^",2),0)) D
  1. 	.S IBTNOD=$G(^IBT(356.9,+IBXY(I),0))
  1. 	.W !?2,I,"  ",$P(IBXD,"^"),?15,$E($P(IBXD,"^",3),1,30),?48,$$DAT1^IBOUTL($P($P(IBTNOD,"^",3),"."),2),?60,$$EXPAND^IBTRE(356.9,.04,$P(IBTNOD,"^",4))
  1. 	Q