IBTRE3 ;ALB/AAS - CLAIMS TRACKING EDIT DIAGNOSIS ;1-SEP-93
;;2.0;INTEGRATED BILLING;**10,60,210,266,461**;21-MAR-94;Build 58
;;Per VHA Directive 2004-038, 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,IBSEL
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^IBTUTL4(IBTRN,2)
.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,IBDATE
S IBADG=""
;
S IBDATE=$$TRNDATE^IBACSV(IBTRN) ; Service date for CSV
;
;S IBDGPM=$P(^IBT(356,+IBTRN,0),"^",5)
I IBETYP'=1!('IBDGPM) W !!,"You can only enter an 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," --- "
I 'IBADG W "Unspecified"
E D
. N IBDX
. S IBDX=$$ICD9^IBACSV(+IBADG,IBDATE)
. W $P(IBDX,U)_" -"_$P(IBDX,U,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;.05")
DIAGQ Q
;
ADD(IBTRN,TYPE) ; -- Add a new diagnosis
;
N DTOUT,DUOUT,X,Y,DIC,IBDATE,ICDVDT
S IBCNT=0
;Service date (for CSV)
S IBDATE=$$TRNDATE^IBACSV(IBTRN) S:'IBDATE IBDATE=DT
S ICDVDT=IBDATE ; for DD ID (versioned text)
;
I '$G(TYPE) S TYPE=""
NXT S DIC("A")=$S(TYPE=3:"Admitting Diagnosis: ",IBCNT<1:"Select Diagnosis: ",1:"Next Diagnosis: ")
;
;All DX codes for a version are visible - screen on version (ICD9/ICD10) on date but allows inactive
S DIC("S")="I $$ICD9VER^IBACSV(+Y)="_$$ICD9SYS^IBACSV(IBDATE)
S DIC="^ICD9(",DIC(0)="AEMQI",X=""
W:$G(IBCNT) ! D ^DIC K DIC G ADDQ:Y<0
;
I Y,'$$ICD9ACT^IBACSV(+Y,IBDATE) W !!,*7,$P(Y,U,2)," is not active for the service date ("_$$DAT3^IBOUTL(IBDATE),").",! G NXT
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,DIC("DR")=".05////Y"
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,DIDEL
S DR=$G(IBDR),DIDEL=356.9 I DR="" S DR=".03;.04;.05"
S DA=IBADG,DIE="^IBT(356.9,"
Q:'$G(^IBT(356.9,DA,0))
L +^IBT(356.9,+IBADG):5 I '$T D LOCKED^IBTRCD1 G EDTQ
D ^DIE
L -^IBT(356.9,+IBADG)
EDTQ Q
;
SET(IBTRN) ; -- set array
N IBDGPM,IBICD,IBDA
S IBDGPM=$$DGPM(IBTRN)
S (IBICD,IBCNT)=0
F S IBICD=$O(^IBT(356.9,"ADGPM",IBDGPM,IBICD)) Q:'IBICD S IBDA=0 F S IBDA=$O(^IBT(356.9,"ADGPM",IBDGPM,IBICD,IBDA)) Q:'IBDA D
.Q:'$D(^IBT(356.9,+IBDA,0))
.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,IBDATE
W !
S I=0 F S I=$O(IBXY(I)) Q:'I D
. S IBTNOD=$G(^IBT(356.9,+IBXY(I),0))
. S IBDATE=$P($P(IBTNOD,U,3),".")
. S IBXD=$$ICD9^IBACSV(+$P(IBXY(I),U,2),IBDATE)
. W !?1,I," ",$P(IBXD,U),?14,$E($P(IBXD,U,3),1,30),?47,$$DAT1^IBOUTL(IBDATE),?58,$$EXPAND^IBTRE(356.9,.04,$P(IBTNOD,U,4)),?69,"ICD-",$S($P(IBXD,U,19)=1:9,1:10) I $P(IBTNOD,U,5)'="" W ?77,"(",$P(IBTNOD,U,5),")"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBTRE3 4982 printed Apr 09, 2024@21:04:33 Page 2
IBTRE3 ;ALB/AAS - CLAIMS TRACKING EDIT DIAGNOSIS ;1-SEP-93
+1 ;;2.0;INTEGRATED BILLING;**10,60,210,266,461**;21-MAR-94;Build 58
+2 ;;Per VHA Directive 2004-038, 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,IBSEL
+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^IBTUTL4(IBTRN,2)
+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,IBDATE
+3 SET IBADG=""
+4 ;
+5 ; Service date for CSV
SET IBDATE=$$TRNDATE^IBACSV(IBTRN)
+6 ;
+7 ;S IBDGPM=$P(^IBT(356,+IBTRN,0),"^",5)
+8 IF IBETYP'=1!('IBDGPM)
WRITE !!,"You can only enter an admitting diagnosis for an admission",!
DO PAUSE^VALM1
GOTO ADGQ
+9 ;
+10 SET X="IOINHI;IOINORM"
DO ENDR^%ZISS
+11 SET IBADG=$ORDER(^IBT(356.9,"ADG",IBDGPM,0))
IF IBADG
SET IBDA=$ORDER(^IBT(356.9,"ADG",IBDGPM,IBADG,0))
+12 WRITE !!,"--- ",IOINHI,"Admitting Diagnosis",IOINORM," --- "
+13 IF 'IBADG
WRITE "Unspecified"
+14 IF '$TEST
Begin DoDot:1
+15 NEW IBDX
+16 SET IBDX=$$ICD9^IBACSV(+IBADG,IBDATE)
+17 WRITE $PIECE(IBDX,U)_" -"_$PIECE(IBDX,U,3)
End DoDot:1
+18 IF +IBADG
DO EDT(IBDA,".01;")
WRITE !
+19 IF '$ORDER(^IBT(356.9,"ADG",+IBDGPM,0))
DO ADD(IBTRN,3)
+20 ;
+21 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;.05")
DIAGQ QUIT
+1 ;
ADD(IBTRN,TYPE) ; -- Add a new diagnosis
+1 ;
+2 NEW DTOUT,DUOUT,X,Y,DIC,IBDATE,ICDVDT
+3 SET IBCNT=0
+4 ;Service date (for CSV)
+5 SET IBDATE=$$TRNDATE^IBACSV(IBTRN)
if 'IBDATE
SET IBDATE=DT
+6 ; for DD ID (versioned text)
SET ICDVDT=IBDATE
+7 ;
+8 IF '$GET(TYPE)
SET TYPE=""
NXT SET DIC("A")=$SELECT(TYPE=3:"Admitting Diagnosis: ",IBCNT<1:"Select Diagnosis: ",1:"Next Diagnosis: ")
+1 ;
+2 ;All DX codes for a version are visible - screen on version (ICD9/ICD10) on date but allows inactive
+3 SET DIC("S")="I $$ICD9VER^IBACSV(+Y)="_$$ICD9SYS^IBACSV(IBDATE)
+4 SET DIC="^ICD9("
SET DIC(0)="AEMQI"
SET X=""
+5 if $GET(IBCNT)
WRITE !
DO ^DIC
KILL DIC
if Y<0
GOTO ADDQ
+6 ;
+7 IF Y
IF '$$ICD9ACT^IBACSV(+Y,IBDATE)
WRITE !!,*7,$PIECE(Y,U,2)," is not active for the service date ("_$$DAT3^IBOUTL(IBDATE),").",!
GOTO NXT
+8 IF $DATA(^IBT(356.9,"ADGPM",$$DGPM(IBTRN),+Y))
WRITE !!,*7,$PIECE(Y,"^",2)," is already a diagnosis.",!
GOTO NXT
+9 SET IBCNT=IBCNT+1
+10 SET IBADG=$$NEW(+Y,IBTRN,TYPE)
+11 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 ;
+3 ;
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
SET DIC("DR")=".05////Y"
+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,DIDEL
+3 SET DR=$GET(IBDR)
SET DIDEL=356.9
IF DR=""
SET DR=".03;.04;.05"
+4 SET DA=IBADG
SET DIE="^IBT(356.9,"
+5 if '$GET(^IBT(356.9,DA,0))
QUIT
+6 LOCK +^IBT(356.9,+IBADG):5
IF '$TEST
DO LOCKED^IBTRCD1
GOTO EDTQ
+7 DO ^DIE
+8 LOCK -^IBT(356.9,+IBADG)
EDTQ QUIT
+1 ;
SET(IBTRN) ; -- set array
+1 NEW IBDGPM,IBICD,IBDA
+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=0
FOR
SET IBDA=$ORDER(^IBT(356.9,"ADGPM",IBDGPM,IBICD,IBDA))
if 'IBDA
QUIT
Begin DoDot:1
+5 if '$DATA(^IBT(356.9,+IBDA,0))
QUIT
+6 SET IBCNT=IBCNT+1
+7 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,IBDATE
+4 WRITE !
+5 SET I=0
FOR
SET I=$ORDER(IBXY(I))
if 'I
QUIT
Begin DoDot:1
+6 SET IBTNOD=$GET(^IBT(356.9,+IBXY(I),0))
+7 SET IBDATE=$PIECE($PIECE(IBTNOD,U,3),".")
+8 SET IBXD=$$ICD9^IBACSV(+$PIECE(IBXY(I),U,2),IBDATE)
+9 WRITE !?1,I," ",$PIECE(IBXD,U),?14,$EXTRACT($PIECE(IBXD,U,3),1,30),?47,$$DAT1^IBOUTL(IBDATE),?58,$$EXPAND^IBTRE(356.9,.04,$PIECE(IBTNOD,U,4)),?69,"ICD-",$SELECT($PIECE(IBXD,U,19)=1:9,1:10)
IF $PIECE(IBTNOD,U,5)'=""
WRITE ?77,"(",$PIECE(IBTNOD,U,5),")"
End DoDot:1
+10 QUIT
