- 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 Jan 18, 2025@03:29:01 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