IBTRE3 ;ALB/AAS - CLAIMS TRACKING EDIT DIAGNOSIS ; 1-SEP-93
;;Version 2.0 ; INTEGRATED BILLING ;; 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 - point 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 diagnosis
I IBETYP=2 D G ENQ
.I $P(IBTRND,"^",4) D ASK^SDCO4(+$P(IBTRND,"^",4)) K SDCOQUIT
.I '$P(IBTRND,"^",4) W !!,"Can not add diagnosis to outpatient visits prior to Check-out.",! D PAUSE^VALM1
.S VALMBCK="R"
;
; -- Inpatient diagnosis
I IBETYP=1 D
.Q:'IBDGPM
.;
.; -- ask admitting diagnosis if not already there
.I '$O(^IBT(356.9,"ADG",+IBDGPM,0)) D ADIAG(IBTRN,IBETYP)
.I $G(IBSEL)="^" Q
.;
.; -- edit other diagnosis
.D DIAG(IBTRN,IBETYP)
.S VALMBCK="R"
;
ENQ ;
Q
ADIAG(IBTRN,IBETYP) ; -- add admitting diagnosis
;
N IBADG,DA,DR,DIC,DIE,DD,DO,IOINHI,IOINORM
S IBADG=""
;
;S IBDGPM=$P(^IBT(356,+IBTRN,0),"^",5)
I IBETYP'=1!('IBDGPM) W !!,"You can only enter and admitting diagnosis for an admission",! D PAUSE^VALM1 G ADGQ
;
S X="IOINHI;IOINORM" D ENDR^%ZISS
S IBADG=$O(^IBT(356.9,"ADG",IBDGPM,0)) I IBADG S IBDA=$O(^IBT(356.9,"ADG",IBDGPM,IBADG,0))
W !!,"--- ",IOINHI,"Admitting Diagnosis",IOINORM," --- ",$S('IBADG:"Unspecified",1:$P($G(^ICD9(+IBADG,0)),"^")_" -"_$P(^(0),"^",3))
I +IBADG D EDT(IBDA,".01;") W !
I '$O(^IBT(356.9,"ADG",+IBDGPM,0)) D ADD(IBTRN,3)
;
W !
ADGQ Q
;
DIAG(IBTRN,IBETYP) ; -- add/edit diagnosis
Q:'IBTRN
I $G(IBETYP)'=1 Q
N DA,DR,DIC,DIE
S IBDGPM=$P(^IBT(356,+IBTRN,0),"^",5)
I IBETYP'=1!('IBDGPM) W !!,"You can only enter a diagnosis for an admission",! D PAUSE^VALM1 G ADGQ
;
S X="IOINHI;IOINORM" D ENDR^%ZISS
W !!,"--- ",IOINHI,"Diagnosis",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 DIAGQ
I IBSEL="Add" D ADD(IBTRN)
D:IBSEL EDT(+$G(IBXY(+IBSEL)),".01;.03;.04")
DIAGQ Q
;
ADD(IBTRN,TYPE) ; -- Add a new diagnosis
;
N DTOUT,DUOUT,X,Y,DIC
S IBCNT=0
I '$G(TYPE) S TYPE=""
NXT S DIC("A")=$S(TYPE=3:"Admitting Diagnosis: ",IBCNT<1:"Select Diagnosis: ",1:"Next Diagnosis: ")
S DIC("S")="I '$P(^(0),U,9)"
S DIC="^ICD9(",DIC(0)="AEMQ",X=""
W:$G(IBCNT) ! D ^DIC K DIC G ADDQ:Y<0
I $D(^IBT(356.9,"ADGPM",$$DGPM(IBTRN),+Y)) W !!,*7,$P(Y,"^",2)," is already a diagnosis.",! G NXT
S IBCNT=IBCNT+1
S IBADG=$$NEW(+Y,IBTRN,TYPE)
I IBADG,TYPE'=3 D EDT(IBADG) G NXT
ADDQ I $D(DTOUT)!($D(DUOUT)) S IBSEL="^"
Q
;
DGPM(IBTRN) ; -- return admission pointer
Q $P(^IBT(356,+IBTRN,0),"^",5)
;
NEW(ICDI,IBTRN,TYPE) ; -- file new entry
;
N DA,DD,DO,DIC,DIK,DINUM,DLAYGO,X,Y,I,J
S X=ICDI,(DIC,DIK)="^IBT(356.9,",DIC(0)="L",DLAYGO=356.9
D FILE^DICN S IBADG=+Y
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)
NEWQ Q IBADG
;
EDT(IBADG,IBDR) ; -- edit entry
;
N DR,DIE,DA
S DR=$G(IBDR) I DR="" S DR=".03;.04"
S DA=IBADG,DIE="^IBT(356.9,"
L +^IBT(356.9,+IBADG):5 I '$T D LOCKED^IBTRCD1 G EDTQ
Q:'$G(^IBT(356.9,DA,0))
D ^DIE
L -^IBT(356.9,+IBADG)
EDTQ Q
;
SET(IBTRN) ; -- set array
N IBDGPM,IBICD
S IBDGPM=$$DGPM(IBTRN)
S (IBICD,IBCNT)=0
F S IBICD=$O(^IBT(356.9,"ADGPM",IBDGPM,IBICD)) Q:'IBICD S IBDA=$O(^(IBICD,0)) D
.S IBCNT=IBCNT+1
.S IBXY(IBCNT)=IBDA_"^"_IBICD
SETQ Q
;
LIST(IBXY) ;List Diagnosis Array
; Input -- IBXY Diagnosis Array Subscripted by a Number
; Output -- List Diagnosis Array
N I,IBXD
W !
S I=0 F S I=$O(IBXY(I)) Q:'I S IBXD=$G(^ICD9(+$P(IBXY(I),"^",2),0)) D
.S IBTNOD=$G(^IBT(356.9,+IBXY(I),0))
.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))
Q
IBTRE3 ;ALB/AAS - CLAIMS TRACKING EDIT DIAGNOSIS ; 1-SEP-93
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 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 - point 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 diagnosis
+13 IF IBETYP=2
Begin DoDot:1
+14 IF $PIECE(IBTRND,"^",4)
DO ASK^SDCO4(+$PIECE(IBTRND,"^",4))
KILL SDCOQUIT
+15 IF '$PIECE(IBTRND,"^",4)
WRITE !!,"Can not add diagnosis to outpatient visits prior to Check-out.",!
DO PAUSE^VALM1
+16 SET VALMBCK="R"
End DoDot:1
GOTO ENQ
+17 ;
+18 ; -- Inpatient diagnosis
+19 IF IBETYP=1
Begin DoDot:1
+20 IF 'IBDGPM
QUIT
+21 ;
+22 ; -- ask admitting diagnosis if not already there
+23 IF '$ORDER(^IBT(356.9,"ADG",+IBDGPM,0))
DO ADIAG(IBTRN,IBETYP)
+24 IF $GET(IBSEL)="^"
QUIT
+25 ;
+26 ; -- edit other diagnosis
+27 DO DIAG(IBTRN,IBETYP)
+28 SET VALMBCK="R"
End DoDot:1
+29 ;
ENQ ;
+1 QUIT
ADIAG(IBTRN,IBETYP) ; -- add admitting diagnosis
+1 ;
+2 NEW IBADG,DA,DR,DIC,DIE,DD,DO,IOINHI,IOINORM
+3 SET IBADG=""
+4 ;
+5 ;S IBDGPM=$P(^IBT(356,+IBTRN,0),"^",5)
+6 IF IBETYP'=1!('IBDGPM)
WRITE !!,"You can only enter and admitting diagnosis for an admission",!
DO PAUSE^VALM1
GOTO ADGQ
+7 ;
+8 SET X="IOINHI;IOINORM"
DO ENDR^%ZISS
+9 SET IBADG=$ORDER(^IBT(356.9,"ADG",IBDGPM,0))
IF IBADG
SET IBDA=$ORDER(^IBT(356.9,"ADG",IBDGPM,IBADG,0))
+10 WRITE !!,"--- ",IOINHI,"Admitting Diagnosis",IOINORM," --- ",$SELECT('IBADG:"Unspecified",1:$PIECE($GET(^ICD9(+IBADG,0)),"^")_" -"_$PIECE(^(0),"^",3))
+11 IF +IBADG
DO EDT(IBDA,".01;")
WRITE !
+12 IF '$ORDER(^IBT(356.9,"ADG",+IBDGPM,0))
DO ADD(IBTRN,3)
+13 ;
+14 WRITE !
ADGQ QUIT
+1 ;
DIAG(IBTRN,IBETYP) ; -- add/edit diagnosis
+1 IF 'IBTRN
QUIT
+2 IF $GET(IBETYP)'=1
QUIT
+3 NEW DA,DR,DIC,DIE
+4 SET IBDGPM=$PIECE(^IBT(356,+IBTRN,0),"^",5)
+5 IF IBETYP'=1!('IBDGPM)
WRITE !!,"You can only enter a diagnosis for an admission",!
DO PAUSE^VALM1
GOTO ADGQ
+6 ;
+7 SET X="IOINHI;IOINORM"
DO ENDR^%ZISS
+8 WRITE !!,"--- ",IOINHI,"Diagnosis",IOINORM," --- "
+9 SET IBSEL="Add"
+10 DO SET(IBTRN)
IF $DATA(IBXY)
DO LIST(.IBXY)
SET IBSEL=$$ASK^IBTRE4(IBCNT,"A")
+11 IF IBSEL["^"!(IBSEL["Return")
IF IBSEL["^"
SET IBQUIT=1
GOTO DIAGQ
+12 IF IBSEL="Add"
DO ADD(IBTRN)
+13 IF IBSEL
DO EDT(+$GET(IBXY(+IBSEL)),".01;.03;.04")
DIAGQ QUIT
+1 ;
ADD(IBTRN,TYPE) ; -- Add a new diagnosis
+1 ;
+2 NEW DTOUT,DUOUT,X,Y,DIC
+3 SET IBCNT=0
+4 IF '$GET(TYPE)
SET TYPE=""
NXT SET DIC("A")=$SELECT(TYPE=3:"Admitting Diagnosis: ",IBCNT<1:"Select Diagnosis: ",1:"Next Diagnosis: ")
+1 SET DIC("S")="I '$P(^(0),U,9)"
+2 SET DIC="^ICD9("
SET DIC(0)="AEMQ"
SET X=""
+3 IF $GET(IBCNT)
WRITE !
DO ^DIC
KILL DIC
IF Y<0
GOTO ADDQ
+4 IF $DATA(^IBT(356.9,"ADGPM",$$DGPM(IBTRN),+Y))
WRITE !!,*7,$PIECE(Y,"^",2)," is already a diagnosis.",!
GOTO NXT
+5 SET IBCNT=IBCNT+1
+6 SET IBADG=$$NEW(+Y,IBTRN,TYPE)
+7 IF IBADG
IF TYPE'=3
DO EDT(IBADG)
GOTO NXT
ADDQ IF $DATA(DTOUT)!($DATA(DUOUT))
SET IBSEL="^"
+1 QUIT
+2 ;
DGPM(IBTRN) ; -- return admission pointer
+1 QUIT $PIECE(^IBT(356,+IBTRN,0),"^",5)
+2 ;
NEW(ICDI,IBTRN,TYPE) ; -- file new entry
+1 ;
+2 NEW DA,DD,DO,DIC,DIK,DINUM,DLAYGO,X,Y,I,J
+3 SET X=ICDI
SET (DIC,DIK)="^IBT(356.9,"
SET DIC(0)="L"
SET DLAYGO=356.9
+4 DO FILE^DICN
SET IBADG=+Y
+5 IF IBADG>0
LOCK +^IBT(356.9,IBADG)
SET $PIECE(^IBT(356.9,IBADG,0),"^",2,4)=$$DGPM(IBTRN)_"^"_$PIECE($PIECE(^IBT(356,IBTRN,0),"^",6),".")_"^"_$GET(TYPE)
SET DA=IBADG
DO IX1^DIK
LOCK -^IBT(356.9,IBADG)
NEWQ QUIT IBADG
+1 ;
EDT(IBADG,IBDR) ; -- edit entry
+1 ;
+2 NEW DR,DIE,DA
+3 SET DR=$GET(IBDR)
IF DR=""
SET DR=".03;.04"
+4 SET DA=IBADG
SET DIE="^IBT(356.9,"
+5 LOCK +^IBT(356.9,+IBADG):5
IF '$TEST
DO LOCKED^IBTRCD1
GOTO EDTQ
+6 IF '$GET(^IBT(356.9,DA,0))
QUIT
+7 DO ^DIE
+8 LOCK -^IBT(356.9,+IBADG)
EDTQ QUIT
+1 ;
SET(IBTRN) ; -- set array
+1 NEW IBDGPM,IBICD
+2 SET IBDGPM=$$DGPM(IBTRN)
+3 SET (IBICD,IBCNT)=0
+4 FOR
SET IBICD=$ORDER(^IBT(356.9,"ADGPM",IBDGPM,IBICD))
IF 'IBICD
QUIT
SET IBDA=$ORDER(^(IBICD,0))
Begin DoDot:1
+5 SET IBCNT=IBCNT+1
+6 SET IBXY(IBCNT)=IBDA_"^"_IBICD
End DoDot:1
SETQ QUIT
+1 ;
LIST(IBXY) ;List Diagnosis Array
+1 ; Input -- IBXY Diagnosis Array Subscripted by a Number
+2 ; Output -- List Diagnosis Array
+3 NEW I,IBXD
+4 WRITE !
+5 SET I=0
FOR
SET I=$ORDER(IBXY(I))
IF 'I
QUIT
SET IBXD=$GET(^ICD9(+$PIECE(IBXY(I),"^",2),0))
Begin DoDot:1
+6 SET IBTNOD=$GET(^IBT(356.9,+IBXY(I),0))
+7 WRITE !?2,I," ",$PIECE(IBXD,"^"),?15,$EXTRACT($PIECE(IBXD,"^",3),1,30),?48,$$DAT1^IBOUTL($PIECE($PIECE(IBTNOD,"^",3),"."),2),?60,$$EXPAND^IBTRE(356.9,.04,$PIECE(IBTNOD,"^",4))
End DoDot:1
+8 QUIT
